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