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