# LANGUAGE TypeOperators #
# LANGUAGE FlexibleInstances #
# LANGUAGE ScopedTypeVariables #
# LANGUAGE UndecidableInstances #
# LANGUAGE MultiParamTypeClasses #
{-# OPTIONS_GHC -fcontext-stack=100 #-}



 -- ( C ) 2004 - 2007 , Oleg Kiselyov &   
 --  's overlooked object system 

 A variation on the shapes example . We encode subtyping through 
 open - ended normal disjoint unions . When we attempt record look - up , we 
 simply require that both summands admit the look - up since we could 
 find that any summand is actually inhabited at the value level . Two 
 strengths of this approach are these : it readily allows for 
 down - casts , and no nominal up - casts are required from the 
 programmer . Down - casts are completely type - safe ; we can only attempt 
 to cast to types that are part of the union . In order to make all this 
 work , we need to define a few new type - level functions . These new 
 functions may eventually be moved to the HList or the OOHaskell 
 libraries . 



-- (C) 2004-2007, Oleg Kiselyov & Ralf Laemmel
-- Haskell's overlooked object system

A variation on the shapes example. We encode subtyping through
open-ended normal disjoint unions. When we attempt record look-up, we
simply require that both summands admit the look-up since we could
find that any summand is actually inhabited at the value level. Two
strengths of this approach are these: it readily allows for
down-casts, and no nominal up-casts are required from the
programmer. Down-casts are completely type-safe; we can only attempt
to cast to types that are part of the union. In order to make all this
work, we need to define a few new type-level functions. These new
functions may eventually be moved to the HList or the OOHaskell
libraries.

-}

module ShapesEither where

import OOHaskell
import ShapesBase
import Data.HList.ConsUnion


-- The explicit type of circles.
-- We can use this type in down-casting.
-- We can also get away w/o such an explicit type.
-- That is, we can do instance-based down-casting; see below.

type Circle a = Record (  GetRadius :=: IO a
                      :*: SetRadius :=: (a -> IO ())
                      :*: Draw      :=: IO ()
                      :*: GetX      :=: IO a
                      :*: GetY      :=: IO a
                      :*: SetX      :=: (a -> IO ())
                      :*: SetY      :=: (a -> IO ())
                      :*: MoveTo    :=: (a -> a -> IO ())
                      :*: MoveBy    :=: (a -> a -> IO ())
                      :*: HNil )


-- We need full instantiation for the downcasts to work.
-- ... or a better comparsion function. (Omitted.)

-- Test case for heterogeneous collections

main = do
  Construct a list of shapes
          s1 <- mfix (rectangle (10::Int) (20::Int) (5::Int) (6::Int))
          s2 <- mfix (circle (15::Int) (25::Int) (8::Int))
          s3 <- mfix (square (35::Int) (45::Int) (8::Int))
          s4 <- mfix (circle (42::Int) (88::Int) (77::Int))
          let scribble =  consEither s1
                         (consEither s2
                         (consEither s3
                         (consEither s4
                          nilEither)))

          -- Handle the shapes in the list polymorphically       
          mapM_ (\s -> do
                          s # draw
                          (s # moveBy) 100 100
                          s # draw)
                scribble

          -- Type-based bound for down-casting
          mapM_ (\s -> maybe (return ())
	                     (\(c::Circle Int) -> do
                                                     c # setRadius $ 10
			                             c # draw)
	                     (downCast s))
                scribble

          -- Value-based bound for down-casting
          mapM_ (\s -> maybe (return ())
	                     (\c -> do
                                       c # setRadius $ 10
			               c # draw)
	                     (downCast s `asTypeOf` Just s2))
                scribble

          -- call a rectangle specific function
          arec <- mfix (rectangle (0::Int) (0::Int) 15 15)
          arec # setWidth $ 30
           arec # setRadius $ 40
          arec # draw


  We instantiate the look - up ( HasField ) class for records .
-- We assure that the constructed unions form reasonable intersection type.

instance (HasField l x v, HasField l y v) 
       => HasField l (Either x y) v 
 where
  hLookupByLabel l (Left x)  =  hLookupByLabel l x
  hLookupByLabel l (Right y) =  hLookupByLabel l y


 We use downCast defined in HList 's ConsUnion , which implicitly 
 uses TypeEq for the projection from the union . When dealing with objects 
 ( records ) , we could replace that TypeEq with the subsumption 
 predicate that returns HTrue if the record contains all the fields of 
 the targeted type . Another design choice : we may assume the label name 
 to determine the type of the corresponding method . That forces the 
 width subtyping and consistent use of names , at least within one union 
 type . In that case , we can process even records with polymorphic 
 fields . 

We use downCast defined in HList's ConsUnion, which implicitly
uses TypeEq for the projection from the union. When dealing with objects
(records), we could replace that TypeEq with the subsumption
predicate that returns HTrue if the record contains all the fields of
the targeted type. Another design choice: we may assume the label name
to determine the type of the corresponding method. That forces the
width subtyping and consistent use of names, at least within one union
type. In that case, we can process even records with polymorphic
fields.
-}


# OPTIONS_GHC -fcontext-stack=100 #
 ( C ) 2004 - 2007 , Oleg Kiselyov &   
  's overlooked object system 
 (C) 2004-2007, Oleg Kiselyov & Ralf Laemmel
 Haskell's overlooked object system
 The explicit type of circles.
 We can use this type in down-casting.
 We can also get away w/o such an explicit type.
 That is, we can do instance-based down-casting; see below.
 We need full instantiation for the downcasts to work.
 ... or a better comparsion function. (Omitted.)
 Test case for heterogeneous collections
 Handle the shapes in the list polymorphically       
 Type-based bound for down-casting
 Value-based bound for down-casting
 call a rectangle specific function
 We assure that the constructed unions form reasonable intersection type.
# LANGUAGE TypeOperators #
# LANGUAGE FlexibleInstances #
# LANGUAGE ScopedTypeVariables #
# LANGUAGE UndecidableInstances #
# LANGUAGE MultiParamTypeClasses #




 A variation on the shapes example . We encode subtyping through 
 open - ended normal disjoint unions . When we attempt record look - up , we 
 simply require that both summands admit the look - up since we could 
 find that any summand is actually inhabited at the value level . Two 
 strengths of this approach are these : it readily allows for 
 down - casts , and no nominal up - casts are required from the 
 programmer . Down - casts are completely type - safe ; we can only attempt 
 to cast to types that are part of the union . In order to make all this 
 work , we need to define a few new type - level functions . These new 
 functions may eventually be moved to the HList or the OOHaskell 
 libraries . 




A variation on the shapes example. We encode subtyping through
open-ended normal disjoint unions. When we attempt record look-up, we
simply require that both summands admit the look-up since we could
find that any summand is actually inhabited at the value level. Two
strengths of this approach are these: it readily allows for
down-casts, and no nominal up-casts are required from the
programmer. Down-casts are completely type-safe; we can only attempt
to cast to types that are part of the union. In order to make all this
work, we need to define a few new type-level functions. These new
functions may eventually be moved to the HList or the OOHaskell
libraries.

-}

module ShapesEither where

import OOHaskell
import ShapesBase
import Data.HList.ConsUnion



type Circle a = Record (  GetRadius :=: IO a
                      :*: SetRadius :=: (a -> IO ())
                      :*: Draw      :=: IO ()
                      :*: GetX      :=: IO a
                      :*: GetY      :=: IO a
                      :*: SetX      :=: (a -> IO ())
                      :*: SetY      :=: (a -> IO ())
                      :*: MoveTo    :=: (a -> a -> IO ())
                      :*: MoveBy    :=: (a -> a -> IO ())
                      :*: HNil )




main = do
  Construct a list of shapes
          s1 <- mfix (rectangle (10::Int) (20::Int) (5::Int) (6::Int))
          s2 <- mfix (circle (15::Int) (25::Int) (8::Int))
          s3 <- mfix (square (35::Int) (45::Int) (8::Int))
          s4 <- mfix (circle (42::Int) (88::Int) (77::Int))
          let scribble =  consEither s1
                         (consEither s2
                         (consEither s3
                         (consEither s4
                          nilEither)))

          mapM_ (\s -> do
                          s # draw
                          (s # moveBy) 100 100
                          s # draw)
                scribble

          mapM_ (\s -> maybe (return ())
	                     (\(c::Circle Int) -> do
                                                     c # setRadius $ 10
			                             c # draw)
	                     (downCast s))
                scribble

          mapM_ (\s -> maybe (return ())
	                     (\c -> do
                                       c # setRadius $ 10
			               c # draw)
	                     (downCast s `asTypeOf` Just s2))
                scribble

          arec <- mfix (rectangle (0::Int) (0::Int) 15 15)
          arec # setWidth $ 30
           arec # setRadius $ 40
          arec # draw


  We instantiate the look - up ( HasField ) class for records .

instance (HasField l x v, HasField l y v) 
       => HasField l (Either x y) v 
 where
  hLookupByLabel l (Left x)  =  hLookupByLabel l x
  hLookupByLabel l (Right y) =  hLookupByLabel l y


 We use downCast defined in HList 's ConsUnion , which implicitly 
 uses TypeEq for the projection from the union . When dealing with objects 
 ( records ) , we could replace that TypeEq with the subsumption 
 predicate that returns HTrue if the record contains all the fields of 
 the targeted type . Another design choice : we may assume the label name 
 to determine the type of the corresponding method . That forces the 
 width subtyping and consistent use of names , at least within one union 
 type . In that case , we can process even records with polymorphic 
 fields . 

We use downCast defined in HList's ConsUnion, which implicitly
uses TypeEq for the projection from the union. When dealing with objects
(records), we could replace that TypeEq with the subsumption
predicate that returns HTrue if the record contains all the fields of
the targeted type. Another design choice: we may assume the label name
to determine the type of the corresponding method. That forces the
width subtyping and consistent use of names, at least within one union
type. In that case, we can process even records with polymorphic
fields.
-}

