packages feed

MetaObject (empty) → 0.0.1

raw patch · 14 files changed

+1013/−0 lines, 14 filesdep +basedep +containersdep +stringtable-atomsetup-changed

Dependencies added: base, containers, stringtable-atom

Files

+ LICENSE view
@@ -0,0 +1,18 @@+Copyright 2008 by Audrey Tang++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to+deal in the Software without restriction, including without limitation the+rights to use, copy, modify, merge, publish, distribute, sublicense, and/or+sell copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:+  +The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.+   +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL+THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ MetaObject.cabal view
@@ -0,0 +1,19 @@+name:               MetaObject+version:            0.0.1+copyright:          2006 Caio Marcelo, 2008 Audrey Tang+license:            BSD3+license-file:       LICENSE+author:             Audrey Tang <audreyt@audreyt.org>+maintainer:         Audrey Tang <audreyt@audreyt.org>+synopsis:           A meta-object system for Haskell based on Perl 6+description:        A meta-object system for Haskell based on Perl 6+stability:          experimental+build-type:         Simple+exposed-modules:    MO.Base MO.Compile.Attribute MO.Compile.Class MO.Compile.Role MO.Compile MO.Run MO.Util MO.Capture MO.Util.C3+build-depends:      base, stringtable-atom, containers+extra-source-files: README+hs-source-dirs:     src++-- executable:         examples/si+-- main-is:            examples/si.hs+-- hs-source-dirs:     ., src
+ README view
@@ -0,0 +1,6 @@+This library provides a class/object/role runtime as well as reflection+facilities, based on the Perl 6 object system.++At the moment it's extremely experimental, with no documentations and+no examples, and as a whole may not make any sense except for existing+users of Pugs. :-)
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/MO/Base.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fparr #-}++module MO.Base (module MO.Base, Invocant, stubInvocant) where+import {-# SOURCE #-} MO.Run+import Data.Maybe+import Data.Typeable+import StringTable.Atom+import MO.Capture+import GHC.PArr+import StringTable.AtomMap as AtomMap++-- Codeable is an abstraction of possible different pieces of code that+-- a method may use as implementation. It's supposed to be used as member+-- of the MethodCompiled structure. A Codeable type need to have a function+-- "run" that accepts Arguments and returns some Invocant.++-- | open type to represent Code+class Monad m => Codeable m c where+    run :: c -> Arguments m -> m (Invocant m)++-- | stub code which always return the same+newtype NoCode m = NoCode (Invocant m)++instance (Typeable (NoCode m), Monad m) => Codeable m (NoCode m) where+    run (NoCode obj) _ = return obj+instance Show (NoCode m) where+    show _ = "<NoCode>"++-- | Pure code that works with any monad.+newtype PureCode = PureCode (forall m. (Typeable1 m, Monad m) => Arguments m -> Invocant m)++instance (Typeable1 m, Monad m) => Codeable m PureCode where+    run (PureCode f) a = return (f a)+instance Show PureCode where+    show _ = "<PureCode>"++-- | Real monadic primitive code.+newtype Monad m => HsCode m = HsCode (Arguments m -> m (Invocant m))++instance (Typeable1 m, Monad m) => Codeable m (HsCode m) where+    run (HsCode f) a = f a+instance Show (HsCode m) where+    show _ = "<HsCode>"+++-- Arguments represents (surprise) arguments that are passed to methods,+-- right now is just a Pugs' Capture type, but could be generalized to a+-- class, in case of separating MO "generic" code from Pugs specifics.++type Arguments m = Capt (Invocant m)+++-- This Invocant refers to the same concept as in Perl-esque syntax:+-- "foo $moose: $a, $b" which means "$moose.foo($a, $b)".++withInvocant :: (Typeable1 m, Monad m) => Arguments m -> Invocant m -> Arguments m+withInvocant args x = CaptMeth{ c_invocant = x, c_feeds = c_feeds args }++getInvocant :: (Typeable1 m, Monad m) => Arguments m -> Maybe (Invocant m)+getInvocant CaptMeth{ c_invocant = x }  = Just x+getInvocant _                           = Nothing++namedArg :: (Typeable1 m, Monad m) => Arguments m -> Atom -> Maybe (Invocant m)+namedArg args key = foldlP findArg Nothing (c_feeds args)+    where+    -- Notice that each feed has a Map with the named arguments (given by f_nameds)+    -- and the values are of type '[:a:]' and not 'a', because of this we get only+    -- the first one. "(!: 0)" means "(!! 0)" in parallel arrays notation.+    -- (is getting only the first one right??)+    findArg Nothing MkFeed{ f_nameds = ns } = fmap (!: 0) (AtomMap.lookup key ns)+    findArg x       _                       = x+
+ src/MO/Capture.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -fglasgow-exts -fparr #-}+module MO.Capture where++import GHC.PArr+import Data.Typeable+import StringTable.Atom+import StringTable.AtomMap as AtomMap+import Data.Monoid++-- | a Capture is a frozen version of the arguments to an application.+data Capt a+    = CaptMeth+        { c_invocant :: a+        , c_feeds    :: [:Feed a:]+        }+    | CaptSub+        { c_feeds    :: [:Feed a:]+        }+    deriving (Show, Eq, Ord, Typeable)+++-- | non-invocant arguments.+data Feed a = MkFeed+    { f_positionals :: [: a :]+    , f_nameds      :: AtomMap [: a :] +        -- ^ maps to [:a:] and not a since if the Sig stipulates+        --   @x, "x => 1, x => 2" constructs @x = (1, 2).+    }+    deriving (Show, Eq, Ord, Typeable)++instance Monoid [: a :] where+    mempty = [: :]+    mappend = (+:+)++instance Monoid (Feed a) where+    mempty = MkFeed mempty mempty+    mappend (MkFeed x1 x2) (MkFeed y1 y2) = MkFeed (mappend x1 y1) (mappend x2 y2)+    mconcat xs = MkFeed (mconcat (map f_positionals xs)) (mconcat (map f_nameds xs))++emptyFeed :: Feed a+emptyFeed = mempty++concatFeeds :: [: Feed a :] -> Feed a+concatFeeds xs = MkFeed (concatMapP f_positionals xs) (foldlP AtomMap.union mempty (mapP f_nameds xs))
+ src/MO/Compile.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -funbox-strict-fields #-}++module MO.Compile where++import MO.Base+import MO.Util++-- A Method must have name and an implementation encapsulated in a+-- MethodCompile type. This abstraction allows having different+-- types of methods, but for now we have only SimpleMethod, which is+-- the minimal sane instance of Method.++type MethodName = Atom++class Monad m => Method m a | a -> m where+    methodName      :: a -> MethodName+    methodCompile   :: a -> MethodCompiled m++instance Monad m => Method m (AnyMethod m) where+    methodName (MkMethod x)    = methodName x+    methodCompile (MkMethod x) = methodCompile x++data SimpleMethod m+    = MkSimpleMethod+        { sm_name        :: MethodName+        , sm_definition  :: MethodCompiled m+        }++instance Monad m => Method m (SimpleMethod m) where+    methodName = sm_name+    methodCompile = sm_definition+++-- AnyMethod may contain any type of the Method class. This makes+-- other functions life easier. And is a common pattern in MO code.++data AnyMethod m = forall a. Method m a => MkMethod !a++-- FIXME: Its not ok to use this since we can define method with+-- same name which are different. +instance Eq (AnyMethod m) where+    MkMethod a == MkMethod b = methodName a == methodName b++instance Ord (AnyMethod m) where+    MkMethod a `compare` MkMethod b = methodName a `compare` (methodName b)++instance Show (AnyMethod m) where+    show (MkMethod m) = show (methodName m)+++-- MethodCompiled represent a method that maybe called (via runMC) with+-- an Arguments and return an Invocant. It may in the future use the+-- Codeable abstraction (see Base.hs) but for now is "just" a Haskell method.++newtype MethodCompiled m = MkMethodCompiled { runMC :: Arguments m -> m (Invocant m) }+
+ src/MO/Compile/Attribute.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}++module MO.Compile.Attribute where+import MO.Base+import MO.Util+import Data.Typeable++type AttributeName = Atom++data Monad m => Attribute m = MkAttribute+    { a_name          :: AttributeName+    , a_accessor_name :: AttributeName+    , a_is_private    :: Bool+    , a_default       :: m (Invocant m)+    }++instance Monad m => Show (Attribute m) where+    show (MkAttribute a b c _) = "<attr:" ++ show (a, b, c) ++ ">"++instance Monad m => Eq (Attribute m) where+    MkAttribute ax bx cx _ == MkAttribute ay by cy _ = (ax, bx, cx) == (ay, by, cy)++instance Monad m => Ord (Attribute m) where+    MkAttribute ax bx cx _ `compare` MkAttribute ay by cy _ = (ax, bx, cx) `compare` (ay, by, cy)++mkAttributeMandatory :: Monad m => AttributeName -> Attribute m+mkAttributeMandatory name = MkAttribute name name False (fail $ "Missing mandatory attribute: " ++ show name)++mkPrivateAttributeMandatory :: Monad m => AttributeName -> Attribute m+mkPrivateAttributeMandatory name = MkAttribute name name True (fail $ "Missing mandatory attribute: " ++ show name)++mkAttributeStub :: (Typeable1 m, Monad m) => AttributeName -> Attribute m+mkAttributeStub name = MkAttribute name name False (return stubInvocant)++mkPrivateAttributeStub :: (Typeable1 m, Monad m) => AttributeName -> Attribute m+mkPrivateAttributeStub name = MkAttribute name name True (return stubInvocant)++mkAttribute :: Monad m => AttributeName -> Invocant m -> Attribute m+mkAttribute name x = MkAttribute name name False (return x)++mkPrivateAttribute :: Monad m => AttributeName -> Invocant m -> Attribute m+mkPrivateAttribute name x = MkAttribute name name True (return x)
+ src/MO/Compile/Class.hs view
@@ -0,0 +1,190 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}++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]++    -- These three methods below are shared between all C3-happy classes.+    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+        -- Take all public attributes of this class and make read-only accessor for them+        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 }+    +--  attribute_grammars       :: c -> [AttributeGrammar]+    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'  -- same type, compare with its Eq+        _       -> False    -- not same type, never eq++instance (Typeable1 m, Monad m) => Show (AnyClass m) where+    show = show . class_name++-- TODO: How hackish is instantiating the AnyMoose for the class Moose?+-- Could it cause serious problems? Well, there's a DRY problem here, but+-- what else?+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+--  attribute_grammars      (MkClass c) = attribute_grammars 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++-- FIXME: hmm.. how to do Subclassing properly, ie. have MOClass and MOClass share about+-- everything except for just a couple of things? Type-classes doesn't seem to+-- match right, specially because I want nice constructors via record syntax.++data (Monad m, Typeable1 m) => MOClass m+    = MkMOClass+        { moc_parents                :: [AnyClass m]+        , moc_roles                  :: [Role m]+--      , moc_attribute_grammar      :: [AttributeGrammar]+        , moc_attributes             :: [Attribute m]+        , moc_public_methods         :: Collection (AnyMethod m)+        , moc_private_methods        :: Collection (AnyMethod m)+        , moc_name                   :: ClassName+        }+        -- deriving (Eq)++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"++-- FIXME: Method then AnyMethod then MethodAttached then AnyMethod again is ugly+newMOClass :: (Typeable1 m, Monad m) => MOClass m -> MOClass m+newMOClass old = new+    where attach        = MkMethod . MkMethodAttached new+          withBless     = insert _bless (blessMOClass new)+          withCreate    = id -- insert "CREATE"   (createMOClass new)+          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+    -- Here we generate a structure from some layout.  The "params" here +    -- contains initial values of those attributes.+    constructor params = do+        -- For each attribute, create a new instance of it.+        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++--    add_class_method c@MkMOClass{siClassMethods = ms} m =+--        c {siClassMethods = m:ms}+++-- MethodAttached +data MethodAttached m+    = forall c a. (Class m c, Method m a) => MkMethodAttached+        !c       -- Origin+        !a       -- Method++instance Monad m => Method m (MethodAttached m) where+    methodName (MkMethodAttached _ m) = methodName m+    methodCompile (MkMethodAttached _ m) = methodCompile m+
+ src/MO/Compile/Role.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}++module MO.Compile.Role where++import MO.Base ()+import MO.Compile+import MO.Run ()+import MO.Util+import MO.Compile.Attribute++-- Delay further abstractions until we need ;)+data Role m = MkRole+    { r_roles                  :: [Role m]+    , r_attributes             :: [Attribute m]+    , r_public_methods         :: Collection (AnyMethod m)+    , r_private_methods        :: Collection (AnyMethod m)+    }+    deriving (Eq)++emptyRole :: Role m+emptyRole = MkRole+          { r_roles                  = [] +          , r_attributes             = []+          , r_public_methods         = emptyCollection+          , r_private_methods        = emptyCollection+          } ++parent_roles :: Role m -> [Role m]+parent_roles = r_roles++role_public_methods, role_private_methods :: Role m -> Collection (AnyMethod m)+role_public_methods     = r_public_methods+role_private_methods    = r_private_methods++role_attributes :: Role m -> [Attribute m]+role_attributes         = r_attributes++all_using_role_shadowing :: (Show a, Ord a) => Role m -> (Role m -> Collection a) -> Collection a+all_using_role_shadowing r f = sym_shadowing r parent_roles f++all_using_role_inheritance :: (Show a, Ord a) => Role m -> (Role m -> Collection a) -> Collection a+all_using_role_inheritance r f = sym_inheritance r parent_roles f
+ src/MO/Run.hs view
@@ -0,0 +1,140 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fparr #-}++module MO.Run (+    module MO.Run,+    module MO.Base+) where++-- FIXME: systematize a nice order for imports (steal Pugs')+import MO.Util+import MO.Base+import MO.Compile as C+import StringTable.AtomMap as M+import Data.Typeable hiding (cast)+import GHC.PArr+import qualified Data.Typeable as Typeable++-- Little overview.+--+-- Suppose someone is calling a method, like: $foo.moose(1,2,3). Usually, we+-- create a MethodInvocation containing "moose" as the name of the method and+-- some Arguments thing, contaning the "1,2,3".+--+-- The "$foo" object is _represented_ by an Invocant datatype, which has a+-- pointer to "$foo" itself and an ResponderInterface (usually provided by the+-- Class that $foo was instantiated), which knows how to answer for a method+-- call, this is called 'dispatch' in the ResponderInterface class.+--+-- One example of ResponderInterface is the MethodTable, it has a Map of+-- MethodCompileds (identified by MethodName). Its 'dispatch' takes an Invocant+-- and a MethodInvocation, add the Invocant to the MInv Arguments,+-- lookup the MInv method name in it's on table, if found, run the compiled method+-- with the augmented Arguments.+--+-- The function ivDispatch does almost same as 'dispatch', but it gets the RI+-- that the Invocant has inside it (given by the Class, for example). So you can+-- think of "$foo.moose(1,2,3)" as a call to+-- "ivDispatch (Invocant_of_$foo) (Arguments_containing_(1,2,3))"+++-- FIXME: At first we thought of having these two abstractions, but now+-- seem unnecessary, but I may be forgetting something :P+-- class Invocation a+-- class Responder a+++data MethodInvocation m+    = MkMethodInvocation+        { mi_name      :: !MethodName  +        , mi_arguments :: !(Arguments m)+        }+++class Monad m => ResponderInterface m a | a -> m where+    fromMethodList :: [(MethodName, MethodCompiled m)] -> m a+    dispatch :: a -> Invocant m -> MethodInvocation m -> m (Invocant m)+    -- here for debugging purposes.+    -- toNameList :: a -> [MethodName]++{-+instance ResponderInterface m a => Show a where+    show = show . toNameList+-}+++data Monad m => NoResponse m = NoResponse++instance Monad m => ResponderInterface m (NoResponse m) where+    dispatch _ _ _      = fail "Dispatch failed - NO CARRIER"+    fromMethodList _    = return NoResponse+    -- toNameList _        = []++emptyResponder :: (Typeable1 m, Monad m) => AnyResponder m+emptyResponder = MkResponder (return NoResponse)++++-- | This is a static method table.+data MethodTable m+    = MkMethodTable+        { mt_methods :: !(M.AtomMap (MethodCompiled m))+        }++instance (Typeable1 m, Monad m) => ResponderInterface m (MethodTable m) where+    fromMethodList = return . MkMethodTable . M.fromList+    dispatch mt responder inv@(MkMethodInvocation n args) = case M.lookup n (mt_methods mt) of+        Just method_compiled -> do+            runMC method_compiled (withInvocant args responder)+        _ -> fail $ "Can't locate object method " ++ show n ++ " of invocant: " ++ show responder+            +    -- toNameList = M.keys . mt_methods+++data AnyResponder m = forall c. ResponderInterface m c => MkResponder !(m c)++instance (Typeable1 m, Monad m) => Typeable (AnyResponder m) where+    typeOf _ = mkTyConApp (mkTyCon "AnyResponder") [typeOf1 (undefined :: m ())]++++-- Invocant represent an object aggregated with an ResponderInterface++data (Typeable1 m, Monad m) => Invocant m+    = forall a. (Show a, Eq a, Ord a, Typeable a) => MkInvocant+        a                   -- Invocant+        (AnyResponder m)    -- Responder++fromInvocant :: forall m b. (Typeable1 m, Monad m, Typeable b) => Arguments m -> m b+fromInvocant CaptSub{}                  = fail "No invocant"+fromInvocant CaptMeth{ c_invocant = MkInvocant x _ } = case Typeable.cast x of+    Just y -> return y+    _      -> fail $ "Could not coerce from " ++ (show $ typeOf x) ++ " to " ++ (show $ typeOf (undefined :: b))+++instance (Typeable1 m, Monad m) => Typeable (Invocant m) where+    typeOf _ = mkTyConApp (mkTyCon "Invocant") [typeOf1 (undefined :: m ())]++ivDispatch :: (Typeable1 m, Monad m) => Invocant m -> MethodInvocation m -> m (Invocant m)+ivDispatch i@(MkInvocant _ (MkResponder ri)) mi = do+    table   <- ri+    dispatch table i mi++instance (Typeable1 m, Monad m) => Show (Invocant m) where+    show (MkInvocant x _) = show x+instance (Typeable1 m, Monad m) => Eq (Invocant m) where+    MkInvocant a _ == MkInvocant b _ = a ?==? b+instance (Typeable1 m, Monad m) => Ord (Invocant m) where+    MkInvocant a _ `compare` MkInvocant b _ = a ?<=>? b++-- Helpers to create simple/empty invocants.+__ :: (Typeable1 m, Monad m, Ord a, Show a, Typeable a) => a -> Invocant m+__ = (`MkInvocant` emptyResponder)++stubInvocant :: (Typeable1 m, Monad m) => Invocant m+stubInvocant = MkInvocant () emptyResponder+++-- Helper to create a Arguments based on a list of Invocants+mkArgs :: (Typeable1 m, Monad m) => [Invocant m] -> Arguments m+mkArgs x = CaptSub{ c_feeds = [: MkFeed { f_positionals = toP x, f_nameds = M.empty } :] }+
+ src/MO/Run.hs-boot view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans #-}+module MO.Run where+import Data.Typeable+data (Typeable1 m, Monad m) => Invocant m+stubInvocant :: (Typeable1 m, Monad m) => Invocant m+instance (Typeable1 m, Monad m) => Show (Invocant m)
+ src/MO/Util.hs view
@@ -0,0 +1,159 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++module MO.Util (+    module MO.Util,+    module MO.Capture,+    module StringTable.Atom,+    trace+) where++import Data.Set (Set)+import qualified Data.Set as Set+import MO.Capture++import Data.Map (Map)+import StringTable.AtomMap as AtomMap+import Control.Monad (when)+import Debug.Trace (trace)+import Data.Typeable hiding (cast)+import GHC.Exts (unsafeCoerce#, Word(W#), Word#)+import StringTable.Atom+import qualified Data.Typeable as Typeable+++-- Stole "on" combinator from ghc-6.7+-- http://haskell.org/ghc/dist/current/docs/libraries/base/Data-Function.html#v%3Aon+infixl 0 `on`+on :: (b -> b -> c) -> (a -> b) -> a -> a -> c+(*) `on` f = \x y -> f x * f y++traceShow :: Show a => a -> b -> b+traceShow = trace . show++traceM :: Monad m => String -> m ()+traceM x = trace x (return ())++-- Compare any two typeable things.+(?==?) :: (Eq a, Typeable a, Typeable b) => a -> b -> Bool+(?==?) x y = case Typeable.cast y of+    Just y' -> x == y'+    _       -> False++-- Order any two typeable things.+(?<=>?) :: (Ord a, Typeable a, Typeable b) => a -> b -> Ordering+(?<=>?) x y = case Typeable.cast y of+    Just y' -> x `compare` y'+    _       -> show (typeOf x) `compare` show (typeOf y)++{-# INLINE addressOf #-}+addressOf :: a -> Word+addressOf x = W# (unsafeCoerce# x)++data Ord a => Collection a+    = MkCollection+    { c_objects :: Set a+    , c_names   :: AtomMap a+    }+    deriving (Eq, Ord, Typeable)+++instance (Ord a, Show a) => Show (Collection a) where+    show (MkCollection _ n) = "<" ++ show n ++ ">"++cmap :: (Ord a, Ord b) => (a -> b) -> Collection a -> Collection b+cmap f MkCollection { c_names = bn } =+    let l = map (\(x,y) -> (x, f y)) (AtomMap.toList bn)+    in newCollection l+    ++-- FIXME: This is not really safe since we could add same object with different+-- names. Must check how Set work and what MO's remove wanted.+remove :: (Monad m, Ord a) => Atom -> a -> Collection a -> m (Collection a)+remove name obj MkCollection{ c_objects = bo, c_names = bn } = do+    return $ MkCollection { c_objects = Set.delete obj bo+                          , c_names   = AtomMap.delete name bn+                          } ++add :: (Monad m, Ord a) => Atom -> a -> Collection a -> m (Collection a)+add name obj c@MkCollection{ c_objects = bo, c_names = bn } = do+    when (includes_name c name) $ fail "can't insert: name confict"+    return $ MkCollection { c_objects = Set.insert obj bo+                          , c_names   = AtomMap.insert name obj bn+                          }++insert :: (Ord a) => Atom -> a -> Collection a -> Collection a+insert name obj MkCollection{ c_objects = bo, c_names = bn } =+    MkCollection { c_objects = Set.insert obj bo+                 , c_names   = AtomMap.insert name obj bn+                 }++emptyCollection :: Ord a => Collection a+emptyCollection = newCollection []++-- FIXME: checks for repetition+newCollection :: Ord a => [(Atom, a)] -> Collection a+newCollection l = MkCollection { c_objects = os, c_names = ns }+    where os = Set.fromList (map snd l)+          ns = AtomMap.fromList l++newCollection' :: Ord a => (a -> Atom) -> [a] -> Collection a+newCollection' f l = newCollection pairs+    where pairs = map (\x -> (f x, x)) l++newCollectionMap :: Ord a => AtomMap a -> Collection a+newCollectionMap ns = MkCollection { c_objects = os, c_names = ns }+    where os = Set.fromList (AtomMap.elems ns)++items :: Ord a => Collection a -> [a]+items c = Set.elems (c_objects c)++items_named :: Ord a => Collection a -> [(Atom, a)]+items_named = AtomMap.toList . c_names++includes :: Ord a => Collection a -> a -> Bool+includes c obj = Set.member obj (c_objects c)++includes_name :: Ord a => Collection a -> Atom -> Bool+includes_name c name = AtomMap.member name (c_names c)++includes_any :: Ord a => Collection a -> [a] -> Bool+includes_any _ [] = False+includes_any c (x:xs) = (includes c x) || (includes_any c xs)++includes_any_name :: Ord a => Collection a -> [Atom] -> Bool+includes_any_name _ [] = False+includes_any_name c (x:xs) = (includes_name c x) || (includes_any_name c xs)++includes_all :: Ord a => Collection a -> [a] -> Bool+includes_all _ [] = False+includes_all c (x:xs) = (includes c x) && (includes_any c xs)++shadow :: Ord a => [Collection a] -> [a]+shadow = AtomMap.elems . shadow'++shadow' :: Ord a => [Collection a] -> AtomMap a+shadow' = AtomMap.unions . map c_names++shadow_collection :: Ord a => [Collection a] -> Collection a+shadow_collection = newCollectionMap . shadow'++merge :: Ord a => [Collection a] -> [a]+merge = AtomMap.elems . merge'++merge' :: Ord a => [Collection a] -> AtomMap a+merge' = foldl (AtomMap.unionWithKey (\k _ _ -> error ("merge conflict: " ++ show k))) AtomMap.empty . map c_names++merge_collection :: Ord a => [Collection a] -> Collection a+merge_collection = newCollectionMap . merge'++sym_shadowing :: (Show a, Ord a) => b -> (b -> [b]) -> (b -> Collection a) -> Collection a+sym_shadowing o parents f = shadow_collection [f o, all_parents]+    where all_parents = sym_merged_parents o parents f++sym_merged_parents :: (Show a, Ord a) => b -> (b -> [b]) -> (b -> Collection a) -> Collection a+sym_merged_parents o parents f = merge_collection cs+    where cs = map (\x -> sym_shadowing x parents f) (parents o)++sym_inheritance :: Ord a => b -> (b -> [b]) -> (b -> (Collection a)) -> Collection a+sym_inheritance o parents f = merge_collection (all_parents ++ [f o])+    where all_parents = map (\p -> sym_inheritance p parents f) (parents o)
+ src/MO/Util/C3.hs view
@@ -0,0 +1,216 @@+-- |+--+-- Module      :  C3+-- Copyright   :  (c) 2006 Caio Marcelo+-- License     :  MIT+--+-- Maintainer  :  cmarcelo@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- C3 method resolution order implementation based on algorithm described+-- in /The Python 2.3 Method Resolution Order, v1.4/, by Michele Simionato+-- available at <http://www.python.org/download/releases/2.3/mro/>. Some+-- tests also copied from Perl module Algorithm::C3.+--+-- The 'main' function contains the test cases.++module MO.Util.C3 (linearize) where++import Data.List (nub)+import Control.Monad (when)+--import Control.Monad.Error -- used for testing++-- | Returns the a linearization using C3 algorithm. Takes a function+-- and an element. We can apply the function in this element to obtain+-- its parents.+linearize :: (Monad m, Eq a) => (a -> m [a]) -> a -> m [a]+linearize = linearize' []++-- | Implementation behind linearize. Keeps a list of seen elements to+-- detect loops in the hierarchy.+linearize' :: (Monad m, Eq a) => [a] -> (a -> m [a]) -> a -> m [a]+linearize' seen p root = do+    when (root `elem` seen) $ fail "loop detected in hierarchy"+    root_ps <- p root+    gran_ps <- mapM (linearize' (root : seen) p) root_ps+    let root_ps' = map (\x -> [x]) root_ps +        gran_ps' = filter (not . null) gran_ps+    a <- merge (gran_ps' ++ root_ps')+    return (root : a)++-- | The merge operation from C3.+merge :: (Monad m, Eq a) => [[a]] -> m [a]+merge []    = return []+merge l     = merge_round candidates l+    where+    candidates = nub (map head l)++-- | Auxiliary function for the merge operation, given a candidate list,+-- find a good candidate, return 'Nothing' if none of them can be used,+-- meaning an impossible merge due conflict. If it finds one, calls+-- 'merge' to find next element in the linearization.+merge_round :: (Monad m, Eq a) => [a] -> [[a]] -> m [a]+merge_round _  [] = return []+merge_round [] _  = fail "merge conflict"+merge_round (c:cs) l+    | good c l = do+        a <- merge clean_list+        return (c:a)+    | otherwise = merge_round cs l+    where+    clean_list      = filter (not . null) (merge_clean c l)+    merge_clean c   = map (filter ((/=) c))++-- |Returns 'True' if a candidate element isn't present in the tail+-- of each list.+good :: Eq a => a -> [[a]] -> Bool+good _ []     = True+good c (x:xs)+    | c `elem` (tail x) = False+    | otherwise         = good c xs+++{-++-- Tests+main = do+    test_many "Simple example 1" ex1 [[O], [A,O], [B]]+    test_many "Simple example 2" ex2 [[O], [A,B,C,O], [B,O], [C,O],[D]]+    test_many "Python MRO first example" py1 [+        [O], [A, B, C, D, E, F, O], [B, D, E, O],+        [C, D, F, O], [D, O], [E, O], [F, O]]+    test_many "Python MRO second example" py2 [+        [O], [A, B, E, C, D, F, O], [B, E, D, O],+        [C, D, F, O], [D, O], [E, O], [F, O]]+    test_many2 "Python MRO conflict example" py3 [+        (O, Just [O]),+        (A, Just [A, X, Y, O]),+        (B, Just [B, Y, X, O]),+        (X, Just [X, O]),+        (Y, Just [Y, O]),+        (C, Nothing),+        (D, Nothing)]+    test_many "Python MRO example which breaks old Py MRO" py4 [+        [O], [A, O], [B, O], [C, O], [D, O], [E, O],+        [K1, A, B, C, O], [K2, D, B, E, O], [K3, D, A, O],+        [Z, K1, K2, K3, D, A, B, C, E, O]]+    test_many "Complex merge from Algorithm::C3" complex [+        [A], [B], [C],+        [D, A, B, C], [E, D, A, B, C], [F, E, D, A, B, C],+        [G, D, A, B, C], [H, G, D, A, B, C],+        [I, H, G, F, E, D, A, B, C],+        [J, F, E, D, A, B, C],+        [K, J, I, H, G, F, E, D, A, B, C]]+    test "Complex merge with loop #1 (A::C3)" infinite_loop1 K (Left "loop detected in hierarchy")+    test "Complex merge with loop #2 (A::C3)" infinite_loop2 K (Left "loop detected in hierarchy")+    test "Complex merge with loop #3 (A::C3)" infinite_loop3 K (Left "loop detected in hierarchy")+    test "Complex merge with loop #4 (A::C3)" infinite_loop4 K (Left "loop detected in hierarchy")+    test "Complex merge with loop #5 (A::C3)" infinite_loop5 K (Left "loop detected in hierarchy")+    test "Complex merge with loop #6 (A::C3)" infinite_loop6 K (Left "loop detected in hierarchy")+    test "Complex merge with loop #7 (A::C3)" infinite_loop7 K (Left "loop detected in hierarchy")+    test "Complex merge with loop #8 (A::C3)" infinite_loop8 K (Left "loop detected in hierarchy")+++        ++data Object =+ O | A | B | C | D | E | F | G | H | I | J | K | K1 | K2 | K3 | X | Y | Z+ deriving (Eq, Show)++ex1 x = case x of+    A -> [O]+    _ -> []++ex2 x = case x of+    A -> [B,C]+    B -> [O]+    C -> [O]+    _ -> []++py1 x = case x of+    O -> []+    A -> [B,C]+    B -> [D,E]+    C -> [D,F]+    _ -> [O]++py2 x = case x of+    O -> []+    A -> [B,C]+    B -> [E,D]+    C -> [D,F]+    _ -> [O]++py3 x = case x of+    O -> []+    A -> [X, Y]+    B -> [Y, X]+    C -> [A, B]+    D -> [B, A]+    _ -> [O]++py4 x = case x of+    O -> []+    K1 -> [A,B,C]+    K2 -> [D,B,E]+    K3 -> [D,A]+    Z -> [K1,K2,K3]+    _ -> [O]++complex x = case x of+    D -> [A,B,C]+    E -> [D]+    F -> [E]+    G -> [D]+    H -> [G]+    I -> [H,F]+    J -> [F]+    K -> [J,I]+    _ -> []++infinite_loop1 x = case x of+    E -> [F]+    y -> complex y++infinite_loop2 x = case x of+    C -> [F]+    y -> complex y++infinite_loop3 x = case x of+    A -> [K]+    y -> complex y++infinite_loop4 x = case x of+    J -> [F, K]+    y -> complex y++infinite_loop5 x = case x of+    H -> [G, K]+    y -> complex y++infinite_loop6 x = case x of+    B -> [B]+    y -> complex y++infinite_loop7 x = case x of+    K -> [I, J, K]+    y -> complex y++infinite_loop8 x = case x of+    D -> [A, B, C, H]+    y -> complex y+++-- Helper functions for testing+test_many  name h l = mapM_ (\x -> test name h (head x) (Just x)) l+test_many2 name h l = mapM_ (\(x,y) -> test name h x y) l+test name h e result = do+    let m = linearize (return . h) e+    if m == result+        then putStrLn    $ "ok - " ++ name ++ ", element " ++ (show e)+        else do putStrLn $ "not ok - " ++ name ++ ", element " ++ (show e)+                putStrLn $ "# expected: " ++ (show result)+                putStrLn $ "#      got: " ++ (show m)++-}