MetaObject 0.0.2 → 0.0.3
raw patch · 4 files changed
+537/−7 lines, 4 files
Files
- MetaObject.cabal +3/−7
- examples/old/mi.hs +124/−0
- examples/old/roles.hs +147/−0
- examples/si.hs +263/−0
MetaObject.cabal view
@@ -1,5 +1,5 @@ name: MetaObject-version: 0.0.2+version: 0.0.3 copyright: 2006 Caio Marcelo, 2008 Audrey Tang license: BSD3 license-file: LICENSE@@ -9,13 +9,9 @@ description: A meta-object system for Haskell based on Perl 6 stability: experimental build-type: Simple-category: Development+category: Development, Pugs 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, haskell98, stringtable-atom, containers-extra-source-files: README+extra-source-files: README, examples/si.hs, examples/old/mi.hs examples/old/roles.hs hs-source-dirs: src---- executable: examples/si--- main-is: examples/si.hs--- hs-source-dirs: ., src
+ examples/old/mi.hs view
@@ -0,0 +1,124 @@+{-# 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")]+ , clsPublicMethods = newCollection' methodName $ 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")]+-- , clsPublicMethods = newCollection' methodName $ map AnyMethod [+-- MkSimpleMethod+-- { smName = "z"+-- , smDefinition = MkMethodCompiled+-- { mcBody = PureCode (const (__("z defined in point3d"))) }+-- }]+ }+++colorful = newMI $ emptyMI+ { clsName = "colorful"+ , clsParents = [AnyClass base]+ , clsAttributes = [mkAttribute "color" (__"prettyColor")]+-- , clsPublicMethods = newCollection' methodName $ map AnyMethod [+-- MkSimpleMethod+-- { smName = "color"+-- , smDefinition = MkMethodCompiled+-- { mcBody = PureCode (const (__("color defined in colorful"))) }+-- }]+ }++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+ { miName = s+ , miArguments = mkArgs (map __ args)+ }++call0 :: (Typeable1 m, Monad m) => String -> MethodInvocation m+call0 s = MkMethodInvocation+ { miName = s+ , miArguments = mkArgs []+ }++make_instance0 box = do+ r' <- ivDispatch box (call0 "bless")+ say ("instance created: " ++ (show r'))+ return r'++check_methods c l = show (sort (all_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."+ 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) -> do+ ok (check_methods c ms) (class_name c ++ " instance methods")+ ) matrix+
+ examples/old/roles.hs view
@@ -0,0 +1,147 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}++import MO.Run+import MO.Compile+import MO.Compile.Class+import MO.Util+import MO.Compile.Role+import Control.Exception (try)+import MO.Compile.Attribute++import Data.List (sort)+import Data.Typeable++say = putStrLn+++no_conflict = newMI $ emptyMI + { clsName = "no_conflict"+ , clsParents = []+ , clsRoles =+ [ make_role [] [make_method ("foo", "foo")] []+ , make_role [] [make_method ("foo2", "foo2")] [] + ]+ }+++shadowed = newMI $ emptyMI + { clsName = "shadowed"+ , clsParents = []+ , clsRoles = [+ make_role [] [make_method ("foo", "foo")]+ [ make_role [] [make_method ("foo", "foo2")] []+ , make_role [] [make_method ("bar", "bar")] []+ ]+ ]+ }+++shadowed_a = newMI $ emptyMI + { clsName = "shadowed_a"+ , clsParents = []+ , clsRoles = [+ make_role [mkAttributeStub "foo"] []+ [ make_role [mkAttributeStub "foo"] [] []+ ]+ ]+ }+++no_conflict_a = newMI $ emptyMI + { clsName = "no_conflict_a"+ , clsParents = []+ , clsRoles =+ [ make_role [mkAttributeStub "foo"] [] []+ , make_role [mkAttributeStub "bar"] [] [] + ]+ }++mkbox s c = MkInvocant s (class_interface c)++no_conflict_box = mkbox "no_conflict" no_conflict+shadowed_box = mkbox "shadowed" shadowed+with_conflict_box = mkbox "with_conflict" with_conflict+shadowed_a_box = mkbox "shadowed_a" shadowed_a+no_conflict_a_box = mkbox "no_conflict_a" no_conflict_a++make_call s = MkMethodInvocation+ { miName = s+ , miArguments = mkArgs [__"moose"]+ }++make_instance box = do+ r' <- ivDispatch box (make_call "bless")+ say ("instance created: " ++ (show r'))+ return r'++check_methods c l = show (sort (all_methods c)) == show (sort l) +check_attributes c l = show (sort (map attrName $ all_attributes c)) == show (sort l) ++ok c msg = if c then say ("ok - " ++ msg) else say ("NOT OK - " ++ msg)++call box c result msg = do+ rv <- try $ ivDispatch box c+ case rv of + Left e -> say ("NOT OK - can't call " ++ msg ++ " - Error: " ++ show e )+ Right r' -> ok ((show r') == (show result)) msg++make_methods :: (Typeable1 m, Monad m) => [(String, String)] -> [AnyMethod m]+make_methods = map make_method++make_method :: (Typeable1 m, Monad m) => (String, String) -> AnyMethod m+make_method (n,n') = AnyMethod (+ MkSimpleMethod { smName = n + , smDefinition = MkMethodCompiled $ PureCode (const (__(n')))+ })++make_role as ms rs = emptyRole+ { roPublicMethods = newCollection' methodName ms+ , roAttributes = as+ , roRoles = rs+ }++with_conflict = newMI $ emptyMI + { clsName = "with_conflict"+ , clsParents = []+ , clsRoles =+ [ make_role [] [make_method ("foo", "foo")] []+ , make_role [] [make_method ("foo", "foo2")] [] + ]+ }++ok_conflict f = do+ rv <- try f+ case rv of+ Left e -> putStrLn ("ok - It worked, yay! The error messages was: " ++ show e)+ _ -> putStrLn "NOT OK - Darn, it didn't work."++++main = do+ -- Create instances+ no_conflict_i <- make_instance no_conflict_box+ shadowed_i <- make_instance shadowed_box+ shadowed_a_i <- make_instance shadowed_a_box+ no_conflict_a_i <- make_instance no_conflict_a_box+ + ok (check_methods no_conflict ["bless", "foo", "foo2"])+ "methods of no_conflict"++ ok (check_methods shadowed ["bless", "foo", "bar"])+ "methods of shadowed"++ call shadowed_i (make_call "foo") "foo" "calling shadowed method foo"+ call shadowed_i (make_call "bar") "bar" "calling non-shadowed method bar" ++ ok (check_methods shadowed_a ["bless", "foo"])+ "instance methods of shadowed_a"+ ok (check_attributes shadowed_a ["foo","foo"])+ "attributes of shadowed_a"+ + ok (check_methods no_conflict_a ["bless", "foo","bar"])+ "instance methods of no_conflict_a"+ ok (check_attributes no_conflict_a ["foo","bar"])+ "attributes of no_conflict_a"++ say "# lets try make a MERGE CONFLICT:"+ ok_conflict (make_instance with_conflict_box)
+ examples/si.hs view
@@ -0,0 +1,263 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}++-- To compile make pugs as usual and use the following command inside src/ directory:+-- ghc -package-conf ../third-party/installed/packages.conf -lpcre -ipcre --make MO/si.hs++import MO.Run+import MO.Compile+import MO.Compile.Class+import MO.Util+import Data.Typeable+import Data.Char+import System.IO++-- A cast-map+class (Typeable a, Ord a, Typeable1 m, Monad m) => Boxable m a | a -> m where+ classOf :: a -> MOClass m+ fromObj :: Invocant m -> m a++-- Helpers for Str type+capitalize = mapEachWord capitalizeWord+ where+ mapEachWord _ [] = []+ mapEachWord f str@(c:cs)+ | isSpace c = c:(mapEachWord f cs)+ | otherwise = f word ++ mapEachWord f rest+ where (word,rest) = break isSpace str+ capitalizeWord [] = []+ capitalizeWord (c:cs) = toUpper c:(map toLower cs)++toQuoteMeta :: Char -> String+toQuoteMeta c =+ if not(isLatin1 c) -- Ignore Unicode characters beyond the 256-th+ || isAsciiUpper c || isAsciiLower c || isDigit c || c == '_'+ then [ c ]+ else [ '\\', c ]++-- XXX - Once MI for native types is made generally "is open" this must be adjusted as well.+instance Boxable IO String where+ classOf _ = mkBoxClass "Str"+ [ "reverse" ... (reverse :: String -> String)+ , "chop" ... (\s -> if null s then s else init s)+ , "split" ... words+ , "lc" ... map toLower+ , "lcfirst" ... (\s -> if null s then s else (toLower (head s)) : (tail s))+ , "uc" ... map toUpper+ , "ucfirst" ... (\s -> if null s then s else (toUpper (head s)) : (tail s))+ , "capitalize" ... capitalize+ , "quotemeta" ... (concat . map toQuoteMeta)+ , "chars" ... length+ --, "graphs" ... undefined+ --, "codes" ... undefined+ --, "bytes" ... undefined+ --, "index" ... undefined+ --, "rindex" ... undefined+ --, "substr" ... undefined+ , "test" !!! (print :: String -> IO ()) -- just to test (!!!) function+ ]+ fromObj (MkInvocant x _) = undefined++instance Boxable IO Int where+ classOf _ = mkBoxClass "Int"+ [ "chr" ... ((:[]) . chr)+ ]+ fromObj (MkInvocant x _) = undefined++instance Boxable IO a => Boxable IO [a] where+ classOf _ = mkBoxClass "List"+ [ "elems" ... (length :: [String] -> Int)+ ]+ fromObj (MkInvocant x _) = undefined++{-++-- Doesn't work, don't know exactly why not...++instance (Typeable a, Ord a, Num a) => Boxable IO a where+ classOf _ = mkBoxClass "Num"+ [ "abs" ... abs+ -- , "floor" ... undefined+ -- , "ceiling" ... undefined+ -- , "round" ... undefined+ -- , "truncate" ... undefined + -- , "exp" ... undefined + -- , "log" ... undefined + -- , "log10" ... undefined + -- , "log2" ... undefined -- :-)+ -- , "rand" ... undefined + -- , "sign" ... undefined + -- , "srand" ... undefined + -- , "sqrt" ... undefined + ]+ fromObj (MkInvocant x _) = undefined+-}++instance Boxable IO Char where+ fromObj (MkInvocant x _) = undefined++instance Boxable IO () where+ fromObj (MkInvocant x _) = undefined+++instance Boxable IO Handle where+ classOf _ = mkBoxClass "Handle"+ [ "close" !!! (hClose :: Handle -> IO ())+ --, "connect" ... undefined -- +1046+ --, "listen" ... undefined+ ] + fromObj (MkInvocant x _) = undefined++instance Ord Handle where+ compare x y = compare (show x) (show y)+{-+mkBoxClass :: forall t (m :: * -> *) (m1 :: * -> *).+ ( Method m1 (AnyMethod m1)+ , Code m1 (HsCode m)+ , Typeable t+ , Typeable1 m+ , Monad m+ , Typeable1 m1+ , Method m1 (SimpleMethod m1)+ ) => String -> [(String, t -> m (Invocant m))] -> MI m1+-}+mkBoxClass cls methods = newMOClass MkMOClass+ { moc_parents = []+ , moc_roles = []+ , moc_attributes = []+ , moc_public_methods = newCollection' methodName $ map mkBoxMethod methods+ , moc_private_methods = newCollection []+ , moc_name = toAtom cls+ }++{-+mkBoxMethod :: forall t (m1 :: * -> *) (m :: * -> *).+ ( Method m (SimpleMethod m)+ , Code m (HsCode m1)+ , Typeable t+ , Typeable1 m1+ , Monad m1+ ) => (String, t -> m1 (Invocant m1)) -> AnyMethod m+-}+mkBoxMethod (meth, fun) = MkMethod $ MkSimpleMethod+ { sm_name = meth+ , sm_definition = MkMethodCompiled $ \args -> do+ str <- fromInvocant args+ fun str -- Note that we expect "fun" to be monadic+ }++-- Hmmm, shall we make combinations for take care of things like a -> b -> a,+-- a -> m (), and other combinations?+instance (Boxable m a, Boxable m b, Boxable m c) => Boxable m (a, b, c) where+ classOf = const (newMOClass emptyMOClass)+ fromObj (MkInvocant x _) = undefined+++-- (...) is used for non-monadic functions, and (!!!) for monadic ones+-- would be nice to make (...) work for both cases.+(...) x y = (toAtom x, mkObj . y)+(!!!) x y = (toAtom x, mkObjM . y)++mkObj :: (Show a, Boxable m a) => a -> m (Invocant m)+mkObj x = return $ MkInvocant x (class_interface (classOf x))++mkObjM :: (Show a, Boxable m a) => m a -> m (Invocant m)+mkObjM x = do+ x' <- x+ return $ MkInvocant x' (class_interface (classOf x'))++inv ./ meth = ivDispatch inv $ MkMethodInvocation (toAtom meth) (mkArgs [])++main = do+ jude <- mkObj "Hey Jude"++ rev_jude <- jude ./ "reverse"+ print rev_jude -- "eduJ yeH"++ print =<< (jude ./ "chop") -- "Hey Jud"+ print =<< (jude ./ "uc") -- "HEY JUDE"+ print =<< (jude ./ "lc") -- "hey jude"+ print =<< (jude ./ "lcfirst") -- "hey Jude"+ print =<< (rev_jude ./ "ucfirst") -- "EduJ yeH"+ print =<< (rev_jude ./ "capitalize") -- "Eduj Yeh"+ + things <- mkObj "lot$ of thing$"+ print =<< (things ./ "quotemeta") -- "lot\\$\\ of\\ thing\\$"++ print =<< (jude ./ "split") -- ["Hey","Jude"]++ things ./ "test" -- prints "lot$ of thing$"++ eight <- jude ./ "chars"+ print eight -- 8+ print =<< (eight ./ "chr") -- "\b"++++{-++-- TODO: get more sugar for constructing this types+xxx = do+ let base = newMI $ emptyMI+ { clsPublicMethods = newCollection' methodName $ map AnyMethod [+ MkSimpleMethod+ { smName = "foo"+ , smDefinition = MkMethodCompiled $ HsCode (const (return $ mkObj ("foo", "boo", "blah")) )+ }+ ]+ , clsName = "base" + }+ sub = newMI $ emptyMI+ { clsParents = [AnyClass base]+ , clsPublicMethods = newCollection' methodName $ map AnyMethod [+ MkSimpleMethod+ { smName = "bar"+ , smDefinition = MkMethodCompiled $ HsCode (const (return $ mkObj "bar") )+ }+ ]+ , clsName = "sub"+ }+ sub2 = newMI $ emptyMI+ { clsParents = [AnyClass base]+ , clsPublicMethods = newCollection' methodName $ map AnyMethod [+ MkSimpleMethod+ { smName = "foo"+ , smDefinition = MkMethodCompiled $ HsCode (const (return $ mkObj "haha, surprise"))+ }+ ]+ , clsName = "sub2"+ }+ base_box = MkInvocant "base" $ class_interface base+ sub_box = MkInvocant "sub" $ class_interface sub+ sub2_box = MkInvocant "sub2" $ class_interface sub2+ call_create = MkMethodInvocation+ { miName = "bless"+ , miArguments = mkArgs [mkObj "moose"]+ }+ call_foo = MkMethodInvocation+ { miName = "foo"+ , miArguments = mkArgs [mkObj "moose"]+ }+ call_bar = MkMethodInvocation+ { miName = "bar"+ , miArguments = mkArgs [mkObj "moose"]+ }++ -- Create instance of base+ base_obj_box <- ivDispatch base_box call_create+ print base_obj_box++ -- Create instance of sub+ sub_obj_box <- ivDispatch sub_box call_create+ print sub_obj_box++ -- Create instance of sub2+ sub2_obj_box <- ivDispatch sub2_box call_create+ print sub2_obj_box++ -- Call foo on base class => would work, because foo is instance method+ print =<< ivDispatch base_box call_foo++ -- Call foo on base class => would work, because foo is instance method+ print =<< ivDispatch base_box call_bar++-}