{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}

import MO.Run
import MO.Compile
import MO.Compile.Class
import MO.Compile.Attribute
import MO.Util
import Debug.Trace

import Data.List (sort)
import Data.Typeable

say = putStrLn

base = newMI $ emptyMI { clsName = "base" }

point = newMI $ emptyMI 
      { clsName = "point"
      , clsParents = [AnyClass base]
      , clsAttributes = [mkAttribute "x" (__"defaultX"), mkAttribute "y" (__"defaultY")]
      , clsMethods = newCollection' name $ map AnyMethod [
        MkSimpleMethod
        { smName = "distance"
        , smDefinition = MkMethodCompiled
                            (PureCode (const (__("distance defined in point"))))
        }]
      }

point3d = newMI $ emptyMI 
        { clsName = "point3d"
        , clsParents = [AnyClass point]
        , clsAttributes = [mkAttribute "z" (__"defaultZ")]
        }


colorful = newMI $ emptyMI
         { clsName = "colorful"
         , clsParents = [AnyClass base]
         , clsAttributes = [mkAttribute "color" (__"prettyColor")]
         }

colorful_point = newMI $ emptyMI
               { clsName = "colorful_point"
               , clsParents = [AnyClass point, AnyClass colorful]
               }

colorful_point3d = newMI $ emptyMI
                 { clsName = "colorful_point3d"
                 , clsParents = [AnyClass point3d, AnyClass colorful]
                 }

mkbox :: forall m. (Typeable1 m, Monad m) => String -> MI m -> Invocant m
mkbox s c = MkInvocant s (class_interface c)

base_box = mkbox "base" base
point_box = mkbox "point" point
point3d_box = mkbox "point3d" point3d
colorful_box = mkbox "colorful" colorful
colorful_point_box = mkbox "colorful_point" colorful_point
colorful_point3d_box = mkbox "colorful_point3d" colorful_point3d


call :: (Typeable a, Ord a, Show a, Typeable1 m, Monad m) => String -> [a] -> MethodInvocation m
call s args = MkMethodInvocation s (ArgList (map __ args)) (__"eu")

call0 :: (Typeable1 m, Monad m) => String -> MethodInvocation m
call0 s = MkMethodInvocation s (ArgList []) (__"eu")

make_instance0 box = do
    r' <- ivDispatch box (call0 "bless")
    say ("instance created: " ++ (show r'))
    return r'

check_class_methods c l = show (sort (all_class_methods c)) == show (sort l)
check_instance_methods c l = show (sort (all_instance_methods c)) == show (sort l) 

ok c msg = if c then say ("ok - " ++ msg) else say ("NOT OK - " ++ msg)

main = do
    -- Create instances
    base_i              <- make_instance0 base_box
    point_i             <- make_instance0 point_box
    point3d_i           <- make_instance0 point3d_box
    colorful_i          <- make_instance0 colorful_box
    colorful_point_i    <- make_instance0 colorful_point_box
    colorful_point3d_i  <- make_instance0 colorful_point3d_box
  
    let precedences = map class_precedence_list
            [base, point, point3d, colorful, colorful_point, colorful_point3d]
        correct = map (map AnyClass) [[base], [point,base], [point3d,point,base]
                   , [colorful,base], [colorful_point,point,colorful,base]
                   , [colorful_point3d,point3d,point,colorful,base]]
    if precedences == correct
        then say "ok - Precedences are fine."
        else say "NOT OK - precedences are wrong."

    -- In Perl 6 methods are available both for class and 
    let matrix =
            [ (base,             ["bless"],              []                   )
            , (point,            ["bless", "distance"], ["x", "y"]            )
            , (point3d,          ["bless", "distance"], ["x", "y", "z"]       )
            , (colorful,         ["bless"], ["color"]                         )
            , (colorful_point,   ["bless", "distance"], ["x", "y", "color"]    )
            , (colorful_point3d, ["bless", "distance"], ["x", "y", "color","z"])
            ]

    mapM_ (\(c,ms,as) -> do
        ok (check_class_methods c ms) (class_name c ++ " class methods")
        ok (check_instance_methods c (ms++as)) (class_name c ++ " instance methods")
        ) matrix