Changeset 7190

Timestamp:

09/28/05 23:08:26 (3 years ago)

Author:

autrijus

Message:

r7196@not: autrijus | 2005-09-28 11:04:59 +0300

r7197@not: autrijus | 2005-09-28 11:28:35 +0300

• beginning of the main pugs cabal file r7198@not: autrijus | 2005-09-28 12:36:41 +0300
• some more metadata for Pugs.cabal. r7211@not: autrijus | 2005-09-28 21:27:14 +0300
• releng: normalize and todoize tests. r7221@not: autrijus | 2005-09-29 00:05:29 +0300
• Remove the unreferenced Pugs.AST.Types.
• Move the ill-named Pugs.Context back inside Pugs.Types.
• Reuse its Tolkien quote for the underquoted Pugs.Version.

Files:

• Pugs.cabal (added)
• pil.cabal (deleted)
• src/Pugs/AST/Internals.hs (modified) (1 diff)
• src/Pugs/AST/Types.hs (deleted)
• src/Pugs/Context.hs (deleted)
• src/Pugs/Eval.hs (modified) (1 diff)
• src/Pugs/Eval/Var.hs (modified) (1 diff)
• src/Pugs/Monads.hs (modified) (1 diff)
• src/Pugs/Parser.hs (modified) (1 diff)
• src/Pugs/Run.hs (modified) (1 diff)
• src/Pugs/Types.hs (modified) (2 diffs)
• src/Pugs/Version.hs (modified) (1 diff)
• t/subroutines/signature_matching.t (modified) (2 diffs)
• t/var/assigning_refs.t (modified) (5 diffs)
• t/var/codevars_should_not_autovivify.t (modified) (1 diff)
• t/var/constant.t (modified) (12 diffs)
• t/var/is_readonly.t (modified) (3 diffs)
• t/var/lazy.t (modified) (1 diff)
• t/var/let.t (modified) (2 diffs)
• t/var/my.t (modified) (1 diff)
• t/var/refs_point_to_containers.t (modified) (4 diffs)

src/Pugs/AST/Internals.hs

@@ -72 +72 @@
 ) where
 import Pugs.Internals
-import Pugs.Context
 import Pugs.Types
 import Pugs.Cont hiding (shiftT, resetT)

src/Pugs/Eval.hs

@@ -35 +35 @@
 import Pugs.Prim
 import Pugs.Prim.List (op0Zip)
-import Pugs.Context
 import Pugs.Monads
 import Pugs.Pretty

src/Pugs/Eval/Var.hs

@@ -16 +16 @@
 import Pugs.Prim.List (op2Fold, op1HyperPrefix, op1HyperPostfix, op2Hyper)
 import Pugs.Prim.Param (foldParam)
-import Pugs.Context
 import Pugs.Pretty
 import Pugs.Config

src/Pugs/Monads.hs

@@ -25 +25 @@
 import Pugs.Internals
 import Pugs.AST
-import Pugs.Context
 import Pugs.Types
 import Control.Monad.RWS

src/Pugs/Parser.hs

@@ -23 +23 @@
 import Pugs.AST
 import Pugs.Types
-import Pugs.Context
 import Pugs.Version (versnum)
 import Pugs.Lexer

src/Pugs/Run.hs

@@ -22 +22 @@
 import Pugs.Internals
 import Pugs.Config
-import Pugs.Context
 import Pugs.AST
 import Pugs.Types

src/Pugs/Types.hs

@@ -12 +12 @@
 
 module Pugs.Types (
-    Type(..), mkType, anyType, showType,
-    ClassTree,
+    Type(..), mkType, anyType, showType, isaType, isaType', deltaType,
+    ClassTree, initTree, addNode,
 
     Cxt(..), 
@@ -169 +169 @@
     show _ = "<tmvar>"
 
+{-|
+Count the total number of types in a class tree, including both internal and
+leaf nodes.
+
+This is used by 'deltaType' to ensure that incompatible types are always
+further apart than compatible types.
+-}
+countTree :: ClassTree -> Int
+countTree (Node _ []) = 1
+countTree (Node _ cs) = 1 + sum (map countTree cs)
+
+{-|
+Find the \'difference\' between two types in the given class tree (for MMD
+purposes and such).
+
+Identical types (that exist in the class tree) produce 0. Compatible types
+will produce a small positive number representing their distance.
+Incompatible will produce a distance larger
+than any two compatible types. If one (or both) of the types doesn't exist in
+the tree, the result is a very large number.
+
+> <scook0> is deltaType supposed to be returning large positive numbers for 
+>            types that are actually incompatible?
+> <autrijus> that is a open design question.
+> <autrijus> it is that way because we want
+> <autrijus> '1'+'2'
+> <autrijus> to work
+> <scook0> I see
+> <autrijus> without having to define <+> as Scalar Scalar
+> <autrijus> I think I did think of leaving a compatibleTypes as remedy
+> <autrijus> to specify things that are fundamentally uncastable
+> <scook0> I think I'll just document the current behaviour for now
+> <autrijus> nod. it is a mess. it really wants a rewrite.
+-}
+deltaType :: ClassTree -- ^ Class tree to use for the comparison
+          -> Type      -- ^ Base type
+          -> Type      -- ^ Possibly-derived type
+          -> Int
+deltaType = junctivate min max $ \tree base target ->
+    let distance = distanceType tree base target in
+    if distance < 0
+        then countTree tree - distance
+        else distance
+
+{-|
+Autothreading of comparisons between junctive types.
+
+Just as autothreading over value junctions will perform an operation on all
+junction elements and combine the results back into a junction, this function
+autothreads some type comparison over all the possible type permutations,
+then combines the results using two user-specified /functions/.
+
+E.g. if we want to check whether the type @(Int|Str)@ is a @Num@, we first
+check whether @Int@ is a @Num@ (@True@), then check whether @Str@ is a num
+(@False@), then combine the results using the specified disjunctive combiner
+(in this case Haskell's @(||)@). The result is thus @True@.
+-}
+junctivate :: (t -> t -> t) -- ^ Function to combine results over disjunctive 
+                            --     (@|@) types
+           -> (t -> t -> t) -- ^ Function to combine results over conjunctive 
+                            --     (@\&@) types
+           -> (ClassTree -> Type -> Type -> t)
+                            -- ^ Function that will actually perform the 
+                            --     comparison (on non-junctive types)
+           -> ClassTree     -- ^ Class tree to pass to the comparison function
+           -> Type          -- ^ First type to compare
+           -> Type          -- ^ Second type to compare
+           -> t
+junctivate or and f tree base target
+    | TypeOr t1 t2 <- target
+    = redo base t1 `or` redo base t2
+    | TypeOr b1 b2 <- base
+    = redo b1 target `or` redo b2 target
+    | TypeAnd t1 t2 <- target
+    = redo base t1 `and` redo base t2
+    | TypeAnd b1 b2 <- base
+    = redo b1 target `and` redo b2 target
+    | otherwise
+    = f tree base target
+    where
+    redo = junctivate or and f tree
+
+-- When saying Int.isa(Scalar), Scalar is the base, Int is the target
+{-|
+A more convenient version of 'isaType\'' that automatically converts the base
+type string into an actual 'Type' value.
+-}
+isaType :: ClassTree -- ^ Class tree to use for the comparison
+        -> String    -- ^ Base type
+        -> Type      -- ^ Possibly-derived type
+        -> Bool
+isaType tree base target = isaType' tree (mkType base) target
+
+{-|
+Return true if the second type (the \'target\') is derived-from or equal-to the 
+first type (the \'base\'), in the context of the given class tree.
+
+This function will autothread over junctive types.
+-}
+isaType' :: ClassTree -- ^ Class tree to use for the comparison
+         -> Type      -- ^ Base type
+         -> Type      -- ^ Possibly-derived type
+         -> Bool
+isaType' = junctivate (||) (&&) $ \tree base target ->
+    distanceType tree base target >= 0
+
+{-|
+Compute the \'distance\' between two types by applying 'findList' to each of
+them, and passing the resulting type chains to 'compareList'.
+
+See 'compareList' for further details.
+-}
+distanceType :: ClassTree -> Type -> Type -> Int
+distanceType tree base target = compareList l1 l2
+--  | not (castOk base target)  = 0
+--  | otherwise = compareList l1 l2
+    where
+    l1 = findList base tree
+    l2 = findList target tree
+
+{-
+-- | (This is currently unused...)
+castOk :: a -> b -> Bool
+castOk _ _ = True
+-}
+
+{-|
+Take two inheritance chains produced by 'findList', and determine how
+\'compatible\' the first one is with the second.
+
+Compatible types will produce a number indicating how distant they are.
+Incompatible types produce a negative number indicating how much the base type
+would need to be relaxed. If one (or both) types doesn't exist in the tree, a 
+large negative number is produced
+
+E.g.:
+
+* comparing @Int@ and @Int@ will produce 0
+
+* comparing @Scalar@ and @String@ will produce 1
+
+* comparing @Num@ and @Scalar@ will produce -2
+
+* comparing @Blorple@ and @Method@ will produce -999 (or similar)
+-}
+compareList :: [Type] -- ^ Base type's chain
+            -> [Type] -- ^ Possibly-derived type's chain
+            -> Int
+compareList [] _ = -999 -- XXX hack (nonexistent base type?)
+compareList _ [] = -999 -- XXX hack (incompatible types)
+compareList l1 l2
+    | last l1 `elem` l2 =   length(l2 \\ l1) -- compatible types
+    | last l2 `elem` l1 = - length(l1 \\ l2) -- anti-compatible types
+    | otherwise = compareList l1 (init l2)
+
+{-|
+Produce the type \'inheritance\' chain leading from the base type (@Any@) to
+the given type.
+
+e.g.
+
+@
+'findList' ('MkType' \"Num\") 'initTree'
+@
+
+will produce the list of types
+
+@
+Any, Void, Object, Scalar, Complex, Num
+@
+
+This function does /not/ expect to be given junctive types.
+-}
+findList :: Type      -- ^ 'Type' to find the inheritance chain of
+         -> ClassTree -- ^ Class tree to look in
+         -> [Type]
+findList base (Node l cs)
+    | base == l                             = [l]
+    | Just ls <- find (not . null) found    = l:ls
+    | otherwise                             = []
+    where
+    found :: [[Type]]
+    found = map (findList base) cs
+
+{-
+{-|
+Pretty-print the initial class tree, using @Tree@'s @drawTree@.
+
+(This seems to be a debugging aid, since it's not actually used anywhere.)
+-}
+prettyTypes :: String
+prettyTypes = drawTree $ fmap show initTree
+-}
+
+{-|
+Add a new \'top-level\' type to the class tree, under @Object@.
+-}
+addNode :: ClassTree -> Type -> ClassTree
+addNode (Node obj [Node any (Node item ns:rest), junc]) typ =
+    Node obj [Node any (Node item ((Node typ []):ns):rest), junc]
+addNode _ _ = error "malformed tree"
+
+{-|
+Default class tree, containing all built-in types.
+-}
+initTree :: ClassTree
+initTree = fmap MkType $ Node "Object"
+    [ Node "Any"
+        [ Node "Item"
+            [ Node "List"
+                [ Node "Lazy"
+                    [ Node "Array"
+                        [ Node "Array::Const" []
+                        , Node "Array::Slice" []
+                        ]
+                    , Node "Hash"
+                        [ Node "Hash::Const" []
+                        , Node "Hash::Env" []
+                        ]
+                    ]
+                , Node "Eager" []
+                ]
+            , Node "Scalar"
+                [ Node "Complex"
+                    [ Node "Num"
+                        [ Node "Rat"
+                            [ Node "Int"
+                                [ Node "Bit" [] ] ] ] ]
+                , Node "Bool" []
+                , Node "Str" []
+                , Node "Ref" []
+                , Node "IO"
+                    [ Node "IO::Dir" []
+                    ]
+                , Node "Socket" []
+                , Node "Thread" []
+                , Node "Code"
+                    [ Node "Routine"
+                        [ Node "Sub"
+                            [ Node "Method" []
+                            , Node "Submethod" []  -- why isn't this a node off Method? - mugwump
+                            ]
+                        , Node "Macro" [] ]
+                    , Node "Block" []
+                    ]
+                , Node "Rul" []
+                , Node "Pugs::Internals::VRule" []
+                , Node "Match" []
+                , Node "Scalar::Const" []
+                , Node "Scalar::Proxy" []
+                , Node "Scalar::Lazy" []
+                , Node "Scalar::Perl5" []
+                , Node "Proxy" []
+                , Node "Control::Caller" []
+                , Node "Time::Local" []
+                , Node "Type"
+                    [ Node "Package"
+                        [ Node "Module"
+                            [ Node "Class"
+                                [ Node "Role" []
+                                , Node "Grammar" []
+                                ] ] ] ]
+                ]
+            ]
+        , Node "Pair" []
+        ]
+    , Node "Junction" [] ]
+

src/Pugs/Version.hs

@@ -3 +3 @@
 {-|
     Version information.
+
+>   Tree and flower and leaf and grass,
+>   Let them pass! Let them pass!
+>   Hill and water under sky,
+>   Pass them by! Pass them by!
+
 -}
 

t/subroutines/signature_matching.t

@@ -8 +8 @@
 # check the subroutine with the closest matching signature is called
 
-sub earth (+$me)               {"me $me"};
-sub earth (+$him)              {"him $him"};
-sub earth (+$me, +$him)        {"me $me him $him"};
-sub earth (+$me, +$him, +$her) {"me $me him $him her $her"};
-sub earth ($me)                {"pos $me"};
-sub earth ($me, +$you)         {"pos $me you $you"};
-sub earth ($me, +$her)         {"pos $me her $her"};
-sub earth ($me, $you)          {"pos $me pos $you"};
-sub earth ($me, $you, +$her)   {"pos $me pos $you her $her"};
+multi earth (+$me)               {"me $me"};
+multi earth (+$him)              {"him $him"};
+multi earth (+$me, +$him)        {"me $me him $him"};
+multi earth (+$me, +$him, +$her) {"me $me him $him her $her"};
+multi earth ($me)                {"pos $me"};
+multi earth ($me, +$you)         {"pos $me you $you"};
+multi earth ($me, +$her)         {"pos $me her $her"};
+multi earth ($me, $you)          {"pos $me pos $you"};
+multi earth ($me, $you, +$her)   {"pos $me pos $you her $her"};
 
 is( earth(me => 1),                     'me 1',             'named me', :todo<feature>);
@@ -38 +38 @@
 #
 
-sub wind ($me, $you, +$her)   {"pos $me pos $you her $her"};
-sub wind ($me, $you)          {"pos $me pos $you"};
-sub wind ($me, +$her)         {"pos $me her $her"};
-sub wind ($me, +$you)         {"pos $me you $you"};
-sub wind ($me)                {"pos $me"};
-sub wind (+$me, +$him, +$her) {"me $me him $him her $her"};
-sub wind (+$me, +$him)        {"me $me him $him"};
-sub wind (+$him)              {"him $him"};
-sub wind (+$me)               {"me $me"};
+multi wind ($me, $you, +$her)   {"pos $me pos $you her $her"};
+multi wind ($me, $you)          {"pos $me pos $you"};
+multi wind ($me, +$her)         {"pos $me her $her"};
+multi wind ($me, +$you)         {"pos $me you $you"};
+multi wind ($me)                {"pos $me"};
+multi wind (+$me, +$him, +$her) {"me $me him $him her $her"};
+multi wind (+$me, +$him)        {"me $me him $him"};
+multi wind (+$him)              {"him $him"};
+multi wind (+$me)               {"me $me"};
 
 is( wind(me => 1),                     'me 1',             'named me', :todo<feature>);

t/var/assigning_refs.t

@@ -21 +21 @@
   my @array    = ($arrayref);
 
-  is +@array, 1, '@array = ($arrayref) does not flatten the arrayref';
+  is +@array, 1, '@array = ($arrayref) does not flatten the arrayref', :todo<bug>;
 }
 
@@ -28 +28 @@
   my @array    = $arrayref;
 
-  is +@array, 1, '@array = $arrayref does not flatten the arrayref';
+  is +@array, 1, '@array = $arrayref does not flatten the arrayref', :todo<bug>;
 }
 
@@ -37 +37 @@
   my %hash    = ($hashref,);
 
-  is +%hash, 1, '%hash = ($hashref,) does not flatten the hashref';
+  is +%hash, 1, '%hash = ($hashref,) does not flatten the hashref', :todo<bug>;
 }
 
@@ -44 +44 @@
   my %hash    = ($hashref);
 
-  is +%hash, 1, '%hash = ($hashref) does not flatten the hashref';
+  is +%hash, 1, '%hash = ($hashref) does not flatten the hashref', :todo<bug>;
 }
 
@@ -51 +51 @@
   my %hash    = $hashref;
 
-  is +%hash, 1, '%hash = $hashref does not flatten the hashref';
+  is +%hash, 1, '%hash = $hashref does not flatten the hashref', :todo<bug>;
 }
 

t/var/codevars_should_not_autovivify.t

@@ -13 +13 @@
 dies_ok {
   &New::Package::foo();
-}, "...but invoking it should die";
+}, "...but invoking it should die", :todo<bug>;

t/var/constant.t

@@ -15 +15 @@
     ';
 
-    ok $ok, "declaring a sigilless constant using 'constant' works";
+    ok $ok, "declaring a sigilless constant using 'constant' works", :todo<feature>;
 }
 
@@ -26 +26 @@
     ';
 
-    ok $ok, "declaring a constant with a sigil using 'constant' works";
+    ok $ok, "declaring a constant with a sigil using 'constant' works", :todo<feature>;
 }
 
@@ -37 +37 @@
     ';
 
-    ok $ok, "declaring a sigilless constant with a type specification using 'constant' works";
+    ok $ok, "declaring a sigilless constant with a type specification using 'constant' works", :todo<feature>;
 }
 
@@ -48 +48 @@
     ';
 
-    ok $ok, "declaring an Unicode constant using 'constant' works";
+    ok $ok, "declaring an Unicode constant using 'constant' works", :todo<feature>;
 }
 
@@ -64 +64 @@
     ';
 
-    is $ok, 3, "a constant declared using 'constant' is actually constant (1)";
+    is $ok, 3, "a constant declared using 'constant' is actually constant (1)", :todo<feature>;
 }
 
@@ -79 +79 @@
     ';
 
-    is $ok, 3, "a constant declared using 'constant' is actually constant (2)";
+    is $ok, 3, "a constant declared using 'constant' is actually constant (2)", :todo<feature>;
 }
 
@@ -94 +94 @@
     ';
 
-    is $ok, 3, "a constant declared using 'constant' is actually constant (3)";
+    is $ok, 3, "a constant declared using 'constant' is actually constant (3)", :todo<feature>;
 }
 
@@ -109 +109 @@
     ';
 
-    is $ok, 3, "a constant declared using 'constant' is actually constant (4)";
+    is $ok, 3, "a constant declared using 'constant' is actually constant (4)", :todo<feature>;
 }
 
@@ -129 +129 @@
     ';
 
-    is $ok, 2, "declaring constants using 'my constant' works";
+    is $ok, 2, "declaring constants using 'my constant' works", :todo<feature>;
 }
 
@@ -147 +147 @@
     ';
 
-    is $ok, 3, "constants declared by 'my constant' shadow correctly";
+    is $ok, 3, "constants declared by 'my constant' shadow correctly", :todo<feature>;
 }
 
@@ -162 +162 @@
     ';
 
-    is $ok, 2, "declaring constants using 'our constant' works";
+    is $ok, 2, "declaring constants using 'our constant' works", :todo<feature>;
 }
 
@@ -177 +177 @@
     ';
 
-    is $ok, 2, "declaring constants using 'constant' creates package-scoped vars";
+    is $ok, 2, "declaring constants using 'constant' creates package-scoped vars", :todo<feature>;
 }

t/var/is_readonly.t

@@ -20 +20 @@
     is $a, 42, "binding the variable now works";
 
-    dies_ok { $a := 17 }, "but binding it again does not work";
+    dies_ok { $a := 17 }, "but binding it again does not work", :todo<feature>;
 }
 
@@ -28 +28 @@
 
     $a := 42;
-    ok (try{ exists $a }), "exists() returns true now";
+    ok (try{ exists $a }), "exists() returns true now", :todo<feature>;
 }
 
@@ -34 +34 @@
     my $a = 3;
 
-    ok (try{ exists $a }), "exists() on a plain normal initialized variable returns true";
+    ok (try{ exists $a }), "exists() on a plain normal initialized variable returns true", :todo<feature>;
 }

t/var/lazy.t

@@ -34 +34 @@
 
   is $var,          42, 'our lazy var still has the correct value';
-  is $was_in_lazy,   1, 'our lazy block was not executed again';
+  is $was_in_lazy,   1, 'our lazy block was not executed again', :todo<bug>;
 }
 

t/var/let.t

@@ -17 +17 @@
     1;
   }
-  is $a, 23, "let() should not restore the variable, as our block exited succesfully (1)";
+  is $a, 23, "let() should not restore the variable, as our block exited succesfully (1)", :todo<feature>;
 }
 
@@ -40 +40 @@
     let $a = 23;
     is $a,       23, "let() changed the variable (2-1)";
-    is $get_a(), 23, "let() changed the variable (2-2)";
+    is $get_a(), 23, "let() changed the variable (2-2)", :todo<feature>;
     1;
   }
-  is $a, 23, "let() should not restore the variable, as our block exited succesfully (2)";
+  is $a, 23, "let() should not restore the variable, as our block exited succesfully (2)", :todo<feature>;
 }
 

t/var/my.t

@@ -11 +11 @@
 
 {
-  dies_ok { my $x; my $x }, "test declare my() variable twice in same scope";
+  is(eval('my $x; my $x; 1'), undef, "test declare my() variable twice in same scope");
 }
 

t/var/refs_point_to_containers.t

@@ -14 +14 @@
 
   $num = 4;
-  is $$ref, 4, "refs to scalars point to containers, not cells or even values (1)";
+  is $$ref, 4, "refs to scalars point to containers, not cells or even values (1)", :todo<bug>;
 
   $num := 5;
-  is $$ref, 5, "refs to scalars point to containers, not cells or even values (2)";
+  is $$ref, 5, "refs to scalars point to containers, not cells or even values (2)", :todo<bug>;
 }
 
@@ -26 +26 @@
 
   @array[1] = 3;
-  is $$ref, 3, "refs to arrays point to containers, not cells or even values (1)";
+  is $$ref, 3, "refs to arrays point to containers, not cells or even values (1)", :todo<bug>;
 
   try { @array[1] := 4 };
-  is $$ref, 4, "refs to arrays point to containers, not cells or even values (2)";
+  is $$ref, 4, "refs to arrays point to containers, not cells or even values (2)", :todo<bug>;