package com.io7m.example.ccatpm;
abstract class ArithmeticExpression
{
/**
* An integer constant.
*/
public final static class ConstantExpression extends ArithmeticExpression
{
private final int value;
@SuppressWarnings("synthetic-access") ConstantExpression(
final int value)
{
super(ExpressionType.EXP_CONSTANT);
this.value = value;
}
public final int getValue()
{
return this.value;
}
}
static enum ExpressionType
{
EXP_CONSTANT,
EXP_PLUS,
EXP_MULTIPLY,
EXP_SUBTRACT
}
/**
* The product of two arithmetic expressions.
*/
public final static class MultiplyExpression extends ArithmeticExpression
{
private final ArithmeticExpression e_left;
private final ArithmeticExpression e_right;
@SuppressWarnings("synthetic-access") MultiplyExpression(
final ArithmeticExpression e_left,
final ArithmeticExpression e_right)
{
super(ExpressionType.EXP_MULTIPLY);
this.e_left = e_left;
this.e_right = e_right;
}
public final ArithmeticExpression getLeft()
{
return this.e_left;
}
public final ArithmeticExpression getRight()
{
return this.e_right;
}
}
/**
* The sum of two arithmetic expressions.
*/
public final static class PlusExpression extends ArithmeticExpression
{
private final ArithmeticExpression e_left;
private final ArithmeticExpression e_right;
@SuppressWarnings("synthetic-access") PlusExpression(
final ArithmeticExpression e_left,
final ArithmeticExpression e_right)
{
super(ExpressionType.EXP_PLUS);
this.e_left = e_left;
this.e_right = e_right;
}
public final ArithmeticExpression getLeft()
{
return this.e_left;
}
public final ArithmeticExpression getRight()
{
return this.e_right;
}
}
/**
* The difference of two arithmetic expressions.
*/
public final static class SubtractExpression extends ArithmeticExpression
{
private final ArithmeticExpression e_left;
private final ArithmeticExpression e_right;
@SuppressWarnings("synthetic-access") SubtractExpression(
final ArithmeticExpression e_left,
final ArithmeticExpression e_right)
{
super(ExpressionType.EXP_SUBTRACT);
this.e_left = e_left;
this.e_right = e_right;
}
public final ArithmeticExpression getLeft()
{
return this.e_left;
}
public final ArithmeticExpression getRight()
{
return this.e_right;
}
}
private final ExpressionType type;
private ArithmeticExpression(
final ExpressionType type)
{
this.type = type;
}
public final ExpressionType getType()
{
return this.type;
}
}
package com.io7m.example.ccatpm;
import com.io7m.example.ccatpm.ArithmeticExpression.ConstantExpression;
import com.io7m.example.ccatpm.ArithmeticExpression.MultiplyExpression;
import com.io7m.example.ccatpm.ArithmeticExpression.PlusExpression;
import com.io7m.example.ccatpm.ArithmeticExpression.SubtractExpression;
public final class Interpreter
{
public static int run(
final ArithmeticExpression expr)
{
switch (expr.getType()) {
case EXP_CONSTANT:
{
final ConstantExpression actual = (ConstantExpression) expr;
return actual.getValue();
}
case EXP_MULTIPLY:
{
final MultiplyExpression actual = (MultiplyExpression) expr;
final int left = Interpreter.run(actual.getLeft());
final int right = Interpreter.run(actual.getRight());
return left * right;
}
case EXP_PLUS:
{
final PlusExpression actual = (PlusExpression) expr;
final int left = Interpreter.run(actual.getLeft());
final int right = Interpreter.run(actual.getRight());
return left + right;
}
case EXP_SUBTRACT:
{
final SubtractExpression actual = (SubtractExpression) expr;
final int left = Interpreter.run(actual.getLeft());
final int right = Interpreter.run(actual.getRight());
return left - right;
}
default:
throw new AssertionError("unreachable!");
}
}
private Interpreter()
{
}
}
package com.io7m.example.ccatpm.visitor;
interface Expression
{
int accept(ExpressionVisitor visitor);
}package com.io7m.example.ccatpm.visitor;
abstract class Binary
{
private final Expression left;
private final Expression right;
public Binary(
final Expression left,
final Expression right)
{
this.left = left;
this.right = right;
}
public final Expression getLeft()
{
return this.left;
}
public final Expression getRight()
{
return this.right;
}
}
package com.io7m.example.ccatpm.visitor;
final class Constant implements Expression
{
private final int value;
public Constant(
final int value)
{
this.value = value;
}
public int getValue()
{
return this.value;
}
@Override public int accept(
final ExpressionVisitor visitor)
{
return visitor.visit(this);
}
}
package com.io7m.example.ccatpm.visitor;
final class Add extends Binary implements Expression
{
public Add(
final Expression left,
final Expression right)
{
super(left, right);
}
@Override public int accept(
final ExpressionVisitor visitor)
{
return visitor.visit(this);
}
}
package com.io7m.example.ccatpm.visitor;
final class Multiply extends Binary implements Expression
{
public Multiply(
final Expression left,
final Expression right)
{
super(left, right);
}
@Override public int accept(
final ExpressionVisitor visitor)
{
return visitor.visit(this);
}
}
package com.io7m.example.ccatpm.visitor;
final class Subtract extends Binary implements Expression
{
public Subtract(
final Expression left,
final Expression right)
{
super(left, right);
}
@Override public int accept(
final ExpressionVisitor visitor)
{
return visitor.visit(this);
}
}
package com.io7m.example.ccatpm.visitor;
interface ExpressionVisitor
{
int visit(Add add);
int visit(Constant constant);
int visit(Multiply multiply);
int visit(Subtract subtract);
}package com.io7m.example.ccatpm.visitor;
public final class Interpreter
{
public static int evaluate(
final Expression expression)
{
return expression.accept(new ExpressionVisitor() {
@Override public int visit(
final Add add)
{
return Interpreter.evaluate(add.getLeft())
+ Interpreter.evaluate(add.getRight());
}
@Override public int visit(
final Constant constant)
{
return constant.getValue();
}
@Override public int visit(
final Multiply multiply)
{
return Interpreter.evaluate(multiply.getLeft())
* Interpreter.evaluate(multiply.getRight());
}
@Override public int visit(
final Subtract subtract)
{
return Interpreter.evaluate(subtract.getLeft())
- Interpreter.evaluate(subtract.getRight());
}
});
}
}
module Shapes where data Circle = MakeCircle Integer deriving Show data Rectangle = MakeRectangle Integer Integer deriving Show data Shape = ShapeCircle Circle | ShapeRectangle Rectangle deriving Show
*Shapes> :type MakeCircle 23 MakeCircle 23 :: Circle *Shapes> :type MakeRectangle 23 11 MakeRectangle 23 11 :: Rectangle *Shapes> :type ShapeCircle (MakeCircle 23) ShapeCircle (MakeCircle 23) :: Shape *Shapes> :type ShapeRectangle (MakeRectangle 23 11) ShapeRectangle (MakeRectangle 23 11) :: Shape
*Shapes> :type ShapeCircle (MakeRectangle 23 11)
<interactive>:1:14:
Couldn't match expected type `Circle' with actual type `Rectangle'
In the return type of a call of `MakeRectangle'
In the first argument of `ShapeCircle', namely
`(MakeRectangle 23 11)'
In the expression: ShapeCircle (MakeRectangle 23 11)
*Shapes> :type ShapeRectangle (MakeCircle 23)
<interactive>:1:17:
Couldn't match expected type `Rectangle' with actual type `Circle'
In the return type of a call of `MakeCircle'
In the first argument of `ShapeRectangle', namely `(MakeCircle 23)'
In the expression: ShapeRectangle (MakeCircle 23)
module ShapeShow where
import Shapes
shape_show :: Shape -> IO ()
shape_show s =
case s of
ShapeRectangle _ -> print "rectangle"
ShapeCircle _ -> print "circle"
module ShapeShowNE where
import Shapes
shape_show_ne :: Shape -> IO ()
shape_show_ne s =
case s of
ShapeRectangle _ -> print "rectangle"
ShapeShowNE.hs:7:3:
Warning: Pattern match(es) are non-exhaustive
In a case alternative: Patterns not matched: ShapeCircle _module ShapeShowOL where
import Shapes
shape_show_ol :: Shape -> IO ()
shape_show_ol s =
case s of
ShapeRectangle _ -> print "rectangle"
ShapeRectangle _ -> print "rectangle"
ShapeShowOL.hs:7:3:
Warning: Pattern match(es) are overlapped
In a case alternative: ShapeRectangle _ -> ...module ShapeWidth where
import Shapes
shape_width :: Shape -> IO ()
shape_width s =
case s of
ShapeRectangle (MakeRectangle width _) -> print width
ShapeCircle (MakeCircle radius) -> print (2 * radius)
module ShapeBoo where
import Shapes
shape_boo :: Shape -> IO ()
shape_boo s =
case s of
_ -> print "Boo!"
module ShapeEquals where
import Shapes
shape_equals :: Shape -> Shape -> Bool
shape_equals s t =
case (s, t) of
(ShapeCircle (MakeCircle r0), ShapeCircle (MakeCircle r1)) -> r0 == r1
(ShapeRectangle (MakeRectangle w0 h0), ShapeRectangle (MakeRectangle w1 h1)) -> (w0 == w1) && (h0 == h1)
(_, _) -> False
module Boolean where data Boolean = True | False deriving Show
module Enumeration where data Color = Red | Blue | Green | Yellow deriving Show
module Option where data Option a = Some a | None deriving Show
module OptionPresent where
import Option
present :: Option a -> IO ()
present o =
case o of
Some _ -> print "present"
None -> print "not present"
*Option> :type None None :: Option a *Option> :type Some Some :: a -> Option a *Option> :type Some True Some True :: Option Bool *Option> :type Some (23 :: Integer) Some (23 :: Integer) :: Option Integer *Option> :type Some (Some (23 :: Integer)) Some (Some (23 :: Integer)) :: Option (Option Integer) *Option> :type Some None Some None :: Option (Option a)
module Choice where data Choice a b = ChoiceLeft a | ChoiceRight b deriving Show
*Choice> :type ChoiceLeft ChoiceLeft :: a -> Choice a b *Choice> :type ChoiceRight ChoiceRight :: b -> Choice a b *Choice> :type ChoiceLeft True ChoiceLeft True :: Choice Bool b *Choice> :type ChoiceRight True ChoiceRight True :: Choice a Bool
module Pair where data Pair a b = MakePair a b deriving Show
*Pair> :type MakePair MakePair :: a -> b -> Pair a b *Pair> :type MakePair True MakePair True :: b -> Pair Bool b *Pair> :type MakePair True (23 :: Integer) MakePair True (23 :: Integer) :: Pair Bool Integer *Pair> :type MakePair (MakePair (23 :: Integer) True) (23 :: Integer) MakePair (MakePair (23 :: Integer) True) (23 :: Integer) :: Pair (Pair Integer Bool) Integer *Pair> :type MakePair (23 :: Integer) (MakePair (MakePair False True) (MakePair True False)) MakePair (23 :: Integer) (MakePair (MakePair False True) (MakePair True False)) :: Pair Integer (Pair (Pair Bool Bool) (Pair Bool Bool))
module NaturalInd where data Natural = Z | S Natural deriving Show
*NaturalInd> :type Z Z :: Natural *NaturalInd> :type S S :: Natural -> Natural -- One *NaturalInd> :type S Z S Z :: Natural -- Two *NaturalInd> :type S (S Z) S (S Z) :: Natural -- Three *NaturalInd> :type S (S (S Z)) S (S (S Z)) :: Natural
module NaturalIndPlus where
import NaturalInd
plus :: Natural -> Natural -> Natural
plus x y =
case (x, y) of
(n, Z) -> n
(n, S m) -> S (plus n m)
-- 0 + 0 = 0 ghci> plus Z Z Z -- 0 + 1 = 1 ghci> plus Z (S Z) S Z -- 1 + 1 = 2 ghci> plus (S Z) (S Z) S (S Z) -- 2 + 2 = 4 ghci> plus (S (S Z)) (S (S Z)) S (S (S (S Z)))
module List where data List a = Empty | Cell a (List a) deriving Show
*List> :type Empty Empty :: List a *List> :type Cell Cell :: a -> List a -> List a *List> :type Cell True Cell True :: List Bool -> List Bool *List> :type Cell True Empty Cell True Empty :: List Bool *List> :type Cell True (Cell False Empty) Cell True (Cell False Empty) :: List Bool -- A list of lists! *List> :type Cell (Cell True Empty) Empty Cell (Cell True Empty) Empty :: List (List Bool)
module ListLength where
list_length :: List a -> Integer
list_length list =
case list of
Null -> 0
Cell _ rest -> 1 + (list_length rest)
module BinaryTree where data BTree a = Leaf | Tree (BTree a) a (BTree a) deriving Show
*BinaryTree> :type Leaf Leaf :: BTree a *BinaryTree> :type Tree Leaf Tree Leaf :: a -> BTree a -> BTree a *BinaryTree> :type Tree Leaf True Tree Leaf True :: BTree Bool -> BTree Bool *BinaryTree> :type Tree Leaf True Leaf Tree Leaf True Leaf :: BTree Bool *BinaryTree> :type Tree Leaf True (Tree Leaf True Leaf) Tree Leaf True (Tree Leaf True Leaf) :: BTree Bool
module Natural (
Natural,
make_natural,
from_natural
) where
import Option
data Natural =
MakeNatural Integer
deriving Show
make_natural :: Integer -> Option Natural
make_natural x =
if x >= 0
then Some (MakeNatural x)
else None
from_natural :: Natural -> Integer
from_natural n =
case n of
MakeNatural m -> m
module Expression where data Expression = Constant Integer | Addition Expression Expression | Multiplication Expression Expression | Subtraction Expression Expression deriving Show
module Interpreter where import Expression run :: Expression -> Integer run (Constant x) = x run (Addition e0 e1) = (run e0) + (run e1) run (Multiplication e0 e1) = (run e0) * (run e1) run (Subtraction e0 e1) = (run e0) - (run e1)
ghci> import Interpreter ghci> run (Constant 23) 23 ghci> run (Addition (Constant 23) (Constant 17)) 40 ghci> run (Multiplication (Constant 23) (Constant 17)) 391