--<PRE>

import Array
import IOExts
import ST
import List(findIndices)

-- Higher order types are type constructors

data Tuple x y = Tuple (x,y)

-- Even Higher Order Types
-- type constructors that take type constructors as arguments

data Tree t a = Tip a | Node (t (Tree t a))

t1 = Node [Tip 3, Tip 0]

data Bin x = Two x x

t2 = Node (Two(Tip 5) (Tip 21))

-- Built in higher order types and their notation

type Arrow = (->) Int Int
type List = [] Int
type Pair = (,) Int Int
type Triple = (,,) Int Int Int

-- Type classes over type constructors

{- Defined in Prelude, so must be commented out here

class Functor f where
    fmap :: (a -> b) -> (f a -> f b)

-- Functor Laws
-- map id = id
-- map (f.g) = map f . map g
-}

-- Examples

data BinTree a = Leaf a | Branch (BinTree a) (BinTree a)

instance Functor BinTree where
   fmap f (Leaf x) = Leaf (f x)
   fmap f (Branch x y) = Branch (fmap f x) (fmap f y)

instance Functor ((,) a) where
   fmap f (x,y) = (x, f y)

data Count x = C(x,Int)
instance Functor Count where
  fmap f (C(x,y)) = C(f x, y)

{- Prelude defined instances

instance Functor [] where
    fmap f []     = []
    fmap f (x:xs) = f x : fmap f xs

instance Functor Maybe where
    fmap f Nothing  = Nothing
    fmap f (Just x) = Just (f x)

-}

--------------------------------------------------
-- Another higher order Class -- Monad
{- Class Monad - predefined in prelude

class Monad m where
    (>>=)  :: m a -> (a -> m b) -> m b
    (>>)   :: m a -> m b -> m b
    return :: a -> m a
    fail   :: String -> m a

    p >> q  = p >>= \ _ -> q
    fail s  = error s
-}

{- Predefined instances

instance Monad [ ] where
    (x:xs) >>= f  =  f x ++ (xs >>= f)
    []     >>= f  =  []
    return x      =  [x]

instance Monad Maybe where
    Just x  >>= k  =  k x
    Nothing >>= k  =  Nothing
    return         =  Just

-}

-- Example of use in the Maybe Monad

find :: Eq a => a -> [(a,b)] -> Maybe b
find x [] = Nothing
find x ((y,a):ys) = if x == y then Just a else find x ys

test a c x =
  do { b <- find a x; return (c+b) }
--------------------------------------------
-- Multiparameter type classes

class Same ref where
  same :: ref a -> ref a -> Bool

class (Monad m,Same ref) => Mutable ref m where
  put :: ref a -> a -> m ()
  get :: ref a -> m a
  new :: a -> m (ref a)


-- A couple of instances

instance Mutable (STRef a) (ST a) where
  put = writeSTRef
  get = readSTRef
  new = newSTRef

instance Same (STRef a) where
  same x y = x==y

instance Mutable IORef IO where
  new = newIORef
  get = readIORef
  put = writeIORef

instance Same IORef where
  same x y = x==y

--------------------------------------------------
-- Example use Unification

data (Mutable ref m ) =>
     Type ref m =
        Tvar (ref (Maybe (Type ref m)))
      | Tgen Int
      | Tarrow (Type ref m) (Type ref m)
      | Ttuple [Type ref m]
      | Tcon String [Type ref m]

-- run down a chain of Type TVar references making them all point
-- to the last item in the chain

prune :: (Monad a, Mutable b a) => Type b a -> a (Type b a)
prune (typ @ (Tvar ref)) =
   do { m <- get ref
      ; case m of
          Just t -> do { newt <- prune t
                       ; put ref (Just newt)
                       ; return newt
                       }
          Nothing -> return typ}
prune x = return x



occursIn :: Mutable ref m => ref (Maybe (Type ref m)) -> Type ref m -> m Bool
occursIn ref1 t =
 do { t2 <- prune t
    ; case t2 of
        Tvar ref2 -> return (same ref1 ref2)
        Tgen n -> return False
        Tarrow a b ->
           do { x <- occursIn ref1 a
              ; if x then return True
                     else occursIn ref1 b
              }
        Ttuple xs ->
           do { bs <- sequence(map (occursIn ref1) xs)
              ; return(any id bs)
              }
        Tcon c xs ->
           do { bs <- sequence(map (occursIn ref1) xs)
              ; return(any id bs)
              }
    }

unify :: Mutable ref m =>
          (Type ref m -> Type ref m -> m [String]) ->
          Type ref m -> Type ref m -> m [String]
unify occursAction x y =
  do { t1 <- prune x
     ; t2 <- prune y
     ; case (t1,t2) of
        (Tvar r1,Tvar r2) ->
           if same r1 r2
              then return []
              else do { put r1 (Just t2); return []}
        (Tvar r1,_) ->
           do { b <- occursIn r1 t2
              ; if b then occursAction t1 t2
                     else do { put r1 (Just t2); return [] }
              }
        (_,Tvar r2) -> unify occursAction t2 t1
        (Tgen n,Tgen m) -> if n==m then return [] else return ["generic error"]
        (Tarrow a b,Tarrow x y) ->
          do { e1 <- unify occursAction a x
             ; e2 <- unify occursAction b y
             ; return (e1 ++ e2)
             }
        (_,_) -> return ["shape match error"]
    }

--------------------------------------------

class Name term name where
  isName :: term -> Maybe name
  fromName :: name -> term

type Var = String
data Term0 =
   Add0 Term0 Term0
 | Const0 Int
 | Lambda0 Var Term0
 | App0 Term0 Term0
 | Var0 Var

instance Name Term0 Var where
  isName (Var0 s) = Just s
  isName _ = Nothing
  fromName s = Var0 s

-----------------------------------------------
-- Another multi parameter type Class

class Gensym monad name where
  newGensym :: monad (String -> monad name)
  gensym :: String -> monad name


--------------------------------------------
-- Yet another

class Mult a b c where
  times :: a -> b -> c

instance Mult Int Int Int where
  times x y  = x * y

instance Ix a => Mult Int (Array a Int) (Array a Int) where
  times x y = fmap (*x) y


----------------------------------------------------------
-- Generic Monad operations from prelude
{-
sequence       :: Monad m => [m a] -> m [a]
sequence       =  foldr mcons (return [])
                    where mcons p q = do x  <- p
                                         xs <- q
                                         return (x:xs)

sequence_      :: Monad m => [m a] -> m ()
sequence_      =  foldr (>>) (return ())

mapM             :: Monad m => (a -> m b) -> [a] -> m [b]
mapM f as        =  sequence (map f as)

mapM_            :: Monad m => (a -> m b) -> [a] -> m ()
mapM_ f as       =  sequence_ (map f as)

(=<<)            :: Monad m => (a -> m b) -> m a -> m b
f =<< x          =  x >>= f
-}


{- Other topics

functional dependencies
implicit parameters


-}
-----------------------------------------------------------
-- The meaning of Overloaded functions

class Equal a where
  equal :: a -> a -> Bool

class Nat a where
  inc :: a -> a
  dec :: a -> a
  zero :: a -> Bool


f0 :: (Equal a, Nat a) => a -> a
f0 x =
  if zero x && equal x x
     then inc x
     else dec x



instance Equal Int where
  equal x y = x==y

instance Nat Int where
  inc x = x+1
  dec x = x+1
  zero 0 = True
  zero n = False

data N = Z | S N

instance Equal N where
  equal Z Z = True
  equal (S x) (S y) = equal x y
  equal _ _ = False

instance Nat N where
  inc x = S x
  dec (S x) = x
  zero Z = True
  zero (S _) = False

instance Equal a => Equal [a] where
  equal [] [] = True
  equal (x:xs) (y:ys) = equal x y && equal xs ys
  equal _ _ = False

instance Nat a => Nat [a] where
  inc xs = map inc xs
  dec xs = map dec xs
  zero xs = all zero xs


---------------------------------------

data EqualL a = EqualL
  { equalM :: a -> a -> Bool
  }

data NatL a = NatL
  { incM :: a -> a
  , decM :: a -> a
  , zeroM :: a -> Bool
  }

f1 :: EqualL a -> NatL a -> a -> a
f1 el nl x =
  if zeroM nl x && equalM el x x
     then incM nl x
     else decM nl x

-- instances using the library passing transform

instance_l1 :: EqualL Int
instance_l1 = EqualL {equalM = equal } where
  equal x y = x==y

instance_l2 :: NatL Int
instance_l2 = NatL { incM=inc, decM=dec, zeroM=zero } where
  inc x = x+1
  dec x = x+1
  zero 0 = True
  zero n = False

instance_l3 :: EqualL N
instance_l3 = EqualL { equalM = equal } where
  equal Z Z = True
  equal (S x) (S y) = equal x y
  equal _ _ = False

instance_l4 :: NatL N
instance_l4 = NatL {incM = inc, decM = dec, zeroM = zero } where
  inc x = S x
  dec (S x) = x
  zero Z = True
  zero (S _) = False

instance_l5 :: EqualL a -> EqualL [a]
instance_l5 lib = EqualL { equalM = equal } where
  equal [] [] = True
  equal (x:xs) (y:ys) = equalM lib x y && equal xs ys
  equal _ _ = False

instance_l6 :: NatL a -> NatL [a]
instance_l6 lib = NatL { incM = inc, decM =dec, zeroM = zero } where
  inc xs = map (incM lib) xs
  dec xs = map (decM lib) xs
  zero xs = all (zeroM lib) xs

---------------------------------

data Proof a b = Ep{from :: a->b, to:: b->a}

data Rep t
  =              Int  (Proof t Int)
  |              Char (Proof t Char)
  |              Unit (Proof t ())
  | forall a b . Arr  (Rep a) (Rep b) (Proof t (a->b))
  | forall a b . Prod (Rep a) (Rep b) (Proof t (a,b))
  | forall a b . Sum  (Rep a) (Rep b) (Proof t (Either a b))
  |              N    (Proof t N)
  | forall a   . List (Rep a) (Proof t [a])


equalX :: Rep a -> a -> a -> Bool

incX  :: Rep a -> a -> a
decX  :: Rep a -> a -> a
zeroX :: Rep a -> a -> Bool


f2 :: Rep a -> a -> a
f2 r x =
  if zeroX r x && equalX r x x
     then incX r x
     else decX r x


incX (Int p)    x = to p (inc (from p x)) where inc x = x+1
incX (N p)      x = to p (inc (from p x)) where inc x = S x
incX (List a p) x = to p (inc (from p x)) where inc xs = map (incX a) xs


decX (Int p)    x = to p (dec (from p x)) where dec x = x+1
decX (N p)      x = to p (dec (from p x)) where dec x = S x
decX (List a p) x = to p (dec (from p x)) where dec xs = map (decX a) xs



zeroX (Int p)    x = zero (from p x) where zero 0 = True
                                           zero n = False
zeroX (N p)      x = zero (from p x) where zero Z = True
                                           zero (S _) = False
zeroX (List a p) x = zero (from p x) where zero xs = all (zeroX a) xs



equalX (Int p)    x y = h equal p x y where equal x y = x==y
equalX (N p)      x y = h equal p x y where equal Z Z = True
                                            equal (S x) (S y) = equal x y
                                            equal _ _ = False
equalX (List a p) x y = h equal p x y where equal [] [] = True
                                            equal (x:xs) (y:ys) = equalX a x y && equal xs ys
                                            equal _ _ = False

h equal p x y = equal (from p x) (from p y)

--</PRE>