{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}
{-|
Context propagators and equalizers.
> Tree and flower and leaf and grass,
> Let them pass! Let them pass!
> Hill and water under sky,
> Pass them by! Pass them by!
(This module could probably use a name change...)
-}
module Pugs.Context (
deltaType,
isaType,
addNode,
initTree
) where
import Pugs.Internals
import Pugs.Types
{-|
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.
> is deltaType supposed to be returning large positive numbers for
> types that are actually incompatible?
> that is a open design question.
> it is that way because we want
> '1'+'2'
> to work
> I see
> without having to define <+> as Scalar Scalar
> I think I did think of leaving a compatibleTypes as remedy
> to specify things that are fundamentally uncastable
> I think I'll just document the current behaviour for now
> 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 any [Node void (Node obj ns:rest)]) typ =
Node any [Node void (Node obj ((Node typ []):ns):rest)]
addNode _ _ = error "malformed tree"
{-|
Default class tree, containing all built-in types.
-}
initTree :: ClassTree
initTree = fmap MkType $ Node "Any" [ Node "Void"
[ Node "Object"
[ Node "List"
[ Node "Lazy"
[ Node "Array"
[ Node "Array::Const" []
, Node "Array::Slice" []
]
, Node "Hash"
[ Node "Hash::Const" []
, Node "Hash::Env" []
]
]
, Node "Eager" []
]
, Node "Pair" []
, 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 "Bare"
[ Node "Parametric" [] ] ]
]
, Node "Rule" []
, Node "Match" []
, Node "Junction" []
, Node "Scalar::Const" []
, Node "Scalar::Proxy" []
, Node "Scalar::Lazy" []
, Node "Scalar::Perl5" []
]
]
, Node "Grammar" []
, Node "Type"
[ Node "Package"
[ Node "Module"
[ Node "Class" [] ] ]
, Node "Trait"
[ Node "PkgTrait" [] ] ] ] ]