Common.hs

{-# LANGUAGE TemplateHaskell, TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Examples.Common
-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
-- License     :  BSD3
-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Common definitions used in examples.
--
--------------------------------------------------------------------------------

module Examples.Common where

import Data.Comp
import Data.Comp.Derive
import Data.Comp.Show ()
import Data.Comp.Equality ()

-- Signature for values and operators
data Value a = Const Int | Pair a a
data Op a    = Add a a | Mult a a | Fst a | Snd a

-- Signature for the simple expression language
type Sig = Op :+: Value

-- Derive boilerplate code using Template Haskell
$(derive [makeFunctor, makeTraversable, makeFoldable,
          makeEqF, makeShowF, smartConstructors, smartAConstructors]
         [''Value, ''Op])
         
         

Desugar.hs

{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
  FlexibleInstances, FlexibleContexts, UndecidableInstances,
  OverlappingInstances, ConstraintKinds #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Examples.Desugar
-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
-- License     :  BSD3
-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Desugaring
--
-- The example illustrates how to compose a term homomorphism and an algebra,
-- exemplified via a desugaring term homomorphism and an evaluation algebra.
-- The example also illustrates how to lift a term homomorphism to annotations,
-- exemplified via a desugaring term homomorphism lifted to terms annotated with
-- source position information.
--
--------------------------------------------------------------------------------

module Examples.Desugar where

import Data.Comp
import Data.Comp.Show ()
import Data.Comp.Derive
import Data.Comp.Desugar
import Examples.Common
import Examples.Eval

-- Signature for syntactic sugar
data Sugar a = Neg a | Swap a

-- Source position information (line number, column number)
data Pos = Pos Int Int
           deriving (Show, Eq)

-- Signature for the simple expression language, extended with syntactic sugar
type Sig' = Sugar :+: Op :+: Value

-- Signature for the simple expression language with annotations
type SigP = Op :&: Pos :+: Value :&: Pos

-- Signature for the simple expression language, extended with syntactic sugar,
-- with annotations
type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos

-- Derive boilerplate code using Template Haskell
$(derive [makeFunctor, makeTraversable, makeFoldable,
          makeEqF, makeShowF, makeOrdF, smartConstructors, smartAConstructors]
         [''Sugar])

instance (Op :<: f, Value :<: f, Functor f) => Desugar Sugar f where
  desugHom' (Neg x)  = iConst (-1) `iMult` x
  desugHom' (Swap x) = iSnd x `iPair` iFst x

evalDesug :: Term Sig' -> Term Value
evalDesug = eval . (desugar :: Term Sig' -> Term Sig)

-- Example: evalEx = iPair (iConst 2) (iConst 1)
evalEx :: Term Value
evalEx = evalDesug $ iSwap $ iPair (iConst 1) (iConst 2)

-- Lift desugaring to terms annotated with source positions
desugP :: Term SigP' -> Term SigP
desugP = appHom (propAnn desugHom)

-- Example: desugPEx = iAPair (Pos 1 0)
--                            (iASnd (Pos 1 0) (iAPair (Pos 1 1)
--                                                     (iAConst (Pos 1 2) 1)
--                                                     (iAConst (Pos 1 3) 2)))
--                            (iAFst (Pos 1 0) (iAPair (Pos 1 1)
--                                                     (iAConst (Pos 1 2) 1)
--                                                     (iAConst (Pos 1 3) 2)))
desugPEx :: Term SigP
desugPEx = desugP $ iASwap (Pos 1 0) (iAPair (Pos 1 1) (iAConst (Pos 1 2) 1)
                                                       (iAConst (Pos 1 3) 2))

Eval.hs

{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,
  OverlappingInstances, ConstraintKinds #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Examples.Multi.Eval
-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
-- License     :  BSD3
-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Expression Evaluation
--
-- The example illustrates how to use generalised compositional data types 
-- to implement a small expression language, with a sub language of values, and 
-- an evaluation function mapping expressions to values.
--
--------------------------------------------------------------------------------

module Examples.Multi.Eval where

import Data.Comp.Multi
import Data.Comp.Multi.Derive
import Examples.Multi.Common

-- Term evaluation algebra
class Eval f v where
  evalAlg :: Alg f (Term v)

$(derive [liftSum] [''Eval])

-- Lift the evaluation algebra to a catamorphism
eval :: (HFunctor f, Eval f v) => Term f :-> Term v
eval = cata evalAlg

instance (f :<: v) => Eval f v where
  evalAlg = inject -- default instance

instance (Value :<: v) => Eval Op v where
  evalAlg (Add x y)  = iConst $ projC x + projC y
  evalAlg (Mult x y) = iConst $ projC x * projC y
  evalAlg (Fst x)    = fst $ projP x
  evalAlg (Snd x)    = snd $ projP x

projC :: (Value :<: v) => Term v Int -> Int
projC v = case project v of Just (Const n) -> n

projP :: (Value :<: v) => Term v (s,t) -> (Term v s, Term v t)
projP v = case project v of Just (Pair x y) -> (x,y)

-- Example: evalEx = iConst 2
evalEx :: Term Value Int
evalEx = eval (iFst $ iPair (iConst 2) (iConst 1) :: Term Sig Int)