diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/MetaObject.cabal b/MetaObject.cabal new file mode 100644 --- /dev/null +++ b/MetaObject.cabal @@ -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 +maintainer: Audrey Tang +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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. :-) diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/MO/Base.hs b/src/MO/Base.hs new file mode 100644 --- /dev/null +++ b/src/MO/Base.hs @@ -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 _ = "" + +-- | 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 _ = "" + +-- | 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 _ = "" + + +-- 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 + diff --git a/src/MO/Capture.hs b/src/MO/Capture.hs new file mode 100644 --- /dev/null +++ b/src/MO/Capture.hs @@ -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)) diff --git a/src/MO/Compile.hs b/src/MO/Compile.hs new file mode 100644 --- /dev/null +++ b/src/MO/Compile.hs @@ -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) } + diff --git a/src/MO/Compile/Attribute.hs b/src/MO/Compile/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/MO/Compile/Attribute.hs @@ -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 _) = "" + +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) diff --git a/src/MO/Compile/Class.hs b/src/MO/Compile/Class.hs new file mode 100644 --- /dev/null +++ b/src/MO/Compile/Class.hs @@ -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 + diff --git a/src/MO/Compile/Role.hs b/src/MO/Compile/Role.hs new file mode 100644 --- /dev/null +++ b/src/MO/Compile/Role.hs @@ -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 diff --git a/src/MO/Run.hs b/src/MO/Run.hs new file mode 100644 --- /dev/null +++ b/src/MO/Run.hs @@ -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 } :] } + diff --git a/src/MO/Run.hs-boot b/src/MO/Run.hs-boot new file mode 100644 --- /dev/null +++ b/src/MO/Run.hs-boot @@ -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) diff --git a/src/MO/Util.hs b/src/MO/Util.hs new file mode 100644 --- /dev/null +++ b/src/MO/Util.hs @@ -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) diff --git a/src/MO/Util/C3.hs b/src/MO/Util/C3.hs new file mode 100644 --- /dev/null +++ b/src/MO/Util/C3.hs @@ -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 . 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) + +-}