Restricting values

Image.Types

module Image.Types
    ( Image (Image)
    , Stroke (Line, Arc, Spot)
    , Point (Point)
    , Pen (Circle, Rectangle, ArbitraryPen)
    , pen
    , arcCircle
    , lineRectangle
    , lineCircle
    ) where

data Point = Point Float Float

data Image = Image [Stroke]

data Stroke = Line Point Point LinePen
    | Arc Point Point Point ArcPen
    | Spot Point Pen

data Pen = Circle Float
    | Rectangle Float Float
    | ArbitraryPen deriving (Show)

class Penable a where
    pen :: a -> Pen

instance Penable Pen where
    pen = id

data ArcPen = ArcCircle Pen

instance Penable ArcPen where
    pen (ArcCircle x) = x

data LinePen = LineRectangle Pen
    | LineCircle Pen

instance Penable LinePen where
    pen (LineRectangle p) = p
    pen (LineCircle p) = p

arcCircle :: Float -> ArcPen
arcCircle r = ArcCircle (Circle r)

lineRectangle :: Float -> Float -> LinePen
lineRectangle w h = LineRectangle (Rectangle w h)

lineCircle :: Float -> LinePen
lineCircle r = LineCircle (Circle r)

User

import Image.Types

myPoint :: Point
myPoint = Point 0 0

myLine :: Stroke
myLine = Line myPoint myPoint (lineRectangle 0 0)

myArc :: Stroke
myArc = Arc myPoint myPoint myPoint (arcCircle 0)

mySpot :: Stroke
mySpot = Spot myPoint ArbitraryPen

handleStroke :: Stroke -> String
handleStroke (Line _ _ pn) = "hi " ++ (show . pen $ pn)
handleStroke (Arc _ _ _ pn) = "hi " ++ (show . pen $ pn)
handleStroke (Spot _ pn) = "hi " ++ (show . pen $ pn)

handlePen :: Stroke -> String
handlePen (Line _ _ pn) = describePen . pen $ pn
handlePen  _ = ""

describePen :: Pen -> String
describePen (Circle r) = "Circling " ++ show r
describePen (Rectangle w h) = "Angling " ++ show w ++ "x" ++ show h
describePen _ = "Weird pen"

-- These won't type check:

{-badStroke :: Stroke -> Stroke-}
{-badStroke (Line p1 p2 p) = Line p1 p2 ArbitraryPen-}

{-badStroke2 :: Stroke-}
{-badStroke2 = Line (Point 0 0) (Point 0 0) (ArbitraryPen)-}