module MO.Compile.Class where
import MO.Base ()
import MO.Compile
import MO.Compile.Attribute
import MO.Compile.Role
import MO.Run
import MO.Util
import Data.Typeable (Typeable1, Typeable(..), typeOf1, mkTyCon, mkTyConApp)
import Control.Monad (liftM)
import Data.Monoid
import qualified Data.Typeable as Typeable
import qualified MO.Util.C3 as C3 (linearize)
import qualified Data.Map as Map
type ClassName = Atom
class (Typeable1 m, Monad m, Typeable c, Eq c) => Class m c | c -> m where
class_name :: c -> ClassName
superclasses :: c -> [AnyClass m]
class_precedence_list :: c -> [AnyClass m]
class_precedence_list cls = case C3.linearize (Just . superclasses) (MkClass cls) of
Just ok -> ok
_ -> error "..."
all_attributes :: c -> [Attribute m]
all_attributes c
= concatMap attributes (class_precedence_list c)
++ concatMap allRoleAttributes (roles c)
where
allRoleAttributes r = role_attributes r ++ concatMap allRoleAttributes (parent_roles r)
all_attribute_methods :: c -> [AnyMethod m]
all_attribute_methods c = shadow (from_c ++ [from_r])
where
from_c = map attribute_methods (class_precedence_list c)
from_r = all_using_role_shadowing (merged_roles c) role_attribute_methods
attribute_methods = cmap makeAccessorMethod . newCollection' a_accessor_name . attributes
role_attribute_methods = cmap makeAccessorMethod . newCollection' a_accessor_name . r_attributes
makeAccessorMethod attr = MkMethod $ MkSimpleMethod
{ sm_name = a_accessor_name attr
, sm_definition = MkMethodCompiled $ error . show . getInvocant
}
all_methods :: c -> [AnyMethod m]
all_methods cls = all_attribute_methods cls ++ all_regular_methods cls
all_regular_methods :: c -> [AnyMethod m]
all_regular_methods c = shadow (from_c ++ [from_r])
where from_c = map public_methods (class_precedence_list c)
from_r = all_using_role_shadowing
(merged_roles c) role_public_methods
roles :: c -> [Role m]
merged_roles :: c -> Role m
merged_roles c = emptyRole { r_roles = roles c }
attributes :: c -> [Attribute m]
public_methods :: c -> Collection (AnyMethod m)
private_methods :: c -> Collection (AnyMethod m)
class_interface :: c -> AnyResponder m
class_interface = MkResponder
. (fromMethodList :: [(MethodName, MethodCompiled m)] -> m (MethodTable m))
. map (\m -> (methodName m, methodCompile m))
. all_methods
data AnyClass m = forall c. Class m c => MkClass !c
instance (Typeable1 m, Monad m) => Typeable (AnyClass m) where
typeOf _ = mkTyConApp (mkTyCon "AnyClass") [typeOf1 (undefined :: m ())]
instance (Typeable1 m, Monad m) => Eq (AnyClass m) where
MkClass x == MkClass y = case Typeable.cast y of
Just y' -> x == y'
_ -> False
instance (Typeable1 m, Monad m) => Show (AnyClass m) where
show = show . class_name
instance (Typeable1 m, Monad m) => Class m (AnyClass m) where
class_name (MkClass c) = class_name c
superclasses (MkClass c) = superclasses c
class_precedence_list (MkClass c) = class_precedence_list c
all_methods (MkClass c) = all_methods c
roles (MkClass c) = roles c
attributes (MkClass c) = attributes c
public_methods (MkClass c) = public_methods c
private_methods (MkClass c) = private_methods c
class_interface (MkClass c) = class_interface c
data (Monad m, Typeable1 m) => MOClass m
= MkMOClass
{ moc_parents :: [AnyClass m]
, moc_roles :: [Role m]
, moc_attributes :: [Attribute m]
, moc_public_methods :: Collection (AnyMethod m)
, moc_private_methods :: Collection (AnyMethod m)
, moc_name :: ClassName
}
instance (Typeable1 m, Monad m) => Show (MOClass m) where
show = ('^':) . fromAtom . moc_name
instance (Typeable1 m, Monad m) => Ord (MOClass m) where
compare = compare `on` moc_name
instance (Typeable1 m, Monad m) => Eq (MOClass m) where
(==) = (==) `on` moc_name
instance (Typeable1 m, Monad m) => Typeable (MOClass m) where
typeOf _ = mkTyConApp (mkTyCon "MOClass") [typeOf1 (undefined :: m ())]
emptyMOClass :: (Typeable1 m, Monad m) => MOClass m
emptyMOClass = MkMOClass
{ moc_parents = []
, moc_roles = []
, moc_attributes = []
, moc_public_methods = newCollection []
, moc_private_methods = newCollection []
, moc_name = mempty
}
_bless :: MethodName
_bless = toAtom "bless"
newMOClass :: (Typeable1 m, Monad m) => MOClass m -> MOClass m
newMOClass old = new
where attach = MkMethod . MkMethodAttached new
withBless = insert _bless (blessMOClass new)
withCreate = id
new = old { moc_public_methods = cmap attach . withBless . withCreate $ moc_public_methods old }
blessMOClass :: Class m c => c -> AnyMethod m
blessMOClass c = MkMethod $ MkSimpleMethod
{ sm_name = _bless
, sm_definition = MkMethodCompiled constructor
}
where
constructor params = do
structure <- liftM Map.fromList . (`mapM` all_attributes c) $ \attr -> do
let name = a_name attr
userDefinedVal = namedArg params name
val <- case userDefinedVal of
Just obj -> return obj
_ -> a_default attr
return (a_name attr, val)
return $ MkInvocant structure (class_interface c)
instance (Typeable1 m, Monad m) => Class m (MOClass m) where
class_name = moc_name
superclasses = moc_parents
roles = moc_roles
attributes = moc_attributes
public_methods = moc_public_methods
private_methods = moc_private_methods
data MethodAttached m
= forall c a. (Class m c, Method m a) => MkMethodAttached
!c
!a
instance Monad m => Method m (MethodAttached m) where
methodName (MkMethodAttached _ m) = methodName m
methodCompile (MkMethodAttached _ m) = methodCompile m