Method.hs

module Atomo.Method
    ( addMethod
    , elemsMap
    , emptyMap
    , insertMethod
    , insertMap
    , lookupMap
    , noMethods
    , nullMap
    , toMethods
    ) where

import Data.IORef
import Data.List (elemIndices)
import System.IO.Unsafe
import qualified Data.IntMap as M

import Atomo.Types


-- referring to the left side:
--   LT = higher-precision
--   GT = lower-precision
comparePrecision :: Pattern -> Pattern -> Ordering
comparePrecision (PNamed _ a) (PNamed _ b) =
    comparePrecision a b
comparePrecision (PNamed _ a) b = comparePrecision a b
comparePrecision a (PNamed _ b) = comparePrecision a b
comparePrecision PAny PAny = EQ
comparePrecision PThis PThis = EQ
comparePrecision (PMatch (Reference a)) (PMatch (Reference b))
    | unsafeDelegatesTo (Reference a) (Reference b) = LT
    | unsafeDelegatesTo (Reference a) (Reference b) = GT
    | otherwise = EQ
comparePrecision (PMatch _) (PMatch _) = EQ
comparePrecision (PList as) (PList bs) =
    comparePrecisions as bs
comparePrecision (PPMKeyword _ as) (PPMKeyword _ bs) =
    comparePrecisions as bs
comparePrecision (PHeadTail ah at) (PHeadTail bh bt) =
    comparePrecisions [ah, at] [bh, bt]
comparePrecision (PSingle { ppTarget = at }) (PSingle { ppTarget = bt }) =
    comparePrecision at bt
comparePrecision (PKeyword { ppTargets = as }) (PKeyword { ppTargets = bs }) =
    compareHeads as bs
comparePrecision (PObject _) (PObject _) = EQ
comparePrecision PAny _ = GT
comparePrecision _ PAny = LT
comparePrecision PThis (PMatch (Reference _)) = LT
comparePrecision (PMatch (Reference _)) PThis = GT
comparePrecision (PMatch _) _ = LT
comparePrecision _ (PMatch _) = GT
comparePrecision (PList _) _ = LT
comparePrecision _ (PList _) = GT
comparePrecision (PPMKeyword _ _) _ = LT
comparePrecision _ (PPMKeyword _ _) = GT
comparePrecision (PHeadTail _ _) _ = LT
comparePrecision _ (PHeadTail _ _) = GT
comparePrecision PThis _ = LT
comparePrecision _ PThis = GT
comparePrecision (PObject _) _ = LT
comparePrecision _ (PObject _) = GT
comparePrecision _ _ = GT

compareHeads :: [Pattern] -> [Pattern] -> Ordering
compareHeads [a] [b] = comparePrecision a b
compareHeads (a:as) (b:bs) =
    case comparePrecision a b of
        EQ -> compareHeads as bs
        x -> x
compareHeads a b = error $ "impossible: compareHeads on " ++ show (a, b)

comparePrecisions :: [Pattern] -> [Pattern] -> Ordering
comparePrecisions as bs =
    compare gt lt
  where
    compared = zipWith comparePrecision as bs
    gt = length $ elemIndices GT compared
    lt = length $ elemIndices LT compared

unsafeDelegatesTo :: Value -> Value -> Bool
unsafeDelegatesTo (Reference f) t =
    t `elem` ds || any (`unsafeDelegatesTo` t) ds
  where
    ds = oDelegates (unsafePerformIO (readIORef f))
unsafeDelegatesTo _ _ = False

addMethod :: Method -> MethodMap -> MethodMap
addMethod m mm =
    M.insertWith (\[m'] ms -> insertMethod m' ms) key [m] mm
  where
    key = ppID (mPattern m)

-- insert a method into a list of existing methods
-- most precise goes first, equivalent patterns are replaced
insertMethod :: Method -> [Method] -> [Method]
insertMethod x [] = [x]
insertMethod x ys@(y:ys') =
    case comparePrecision (mPattern x) (mPattern y) of
        -- stop at LT so it's after all of the definitons before this one
        LT -> x : ys

        -- replace equivalent patterns
        _ | mPattern x == mPattern y -> insertMethod x ys'

        -- keep looking if we're EQ or GT
        _ -> y : insertMethod x ys'

toMethods :: [(Pattern, Value)] -> MethodMap
toMethods = foldl (\ss (p, v) -> addMethod (Slot p v) ss) emptyMap

noMethods :: (MethodMap, MethodMap)
noMethods = (M.empty, M.empty)

emptyMap :: MethodMap
emptyMap = M.empty

lookupMap :: Int -> MethodMap -> Maybe [Method]
lookupMap = M.lookup

nullMap :: MethodMap -> Bool
nullMap = M.null

elemsMap :: MethodMap -> [[Method]]
elemsMap = M.elems

insertMap :: Method -> MethodMap -> MethodMap
insertMap m mm = M.insert key [m] mm
  where
    key = ppID (mPattern m)