PatternMatcher.hs

----------------------------------------------------------------------------
-- |
-- Module      :  CSPM.Interpreter.PatternMatcher
-- Copyright   :  (c) Fontaine 2008
-- License     :  BSD
-- 
-- Maintainer  :  Fontaine@cs.uni-duesseldorf.de
-- Stability   :  experimental
-- Portability :  GHC-only
--
-- Execute the selectors of a compilied pattern with a Value.
--
----------------------------------------------------------------------------
{-
todo :
Compiling selectors to pattern meight be an over-kill.
maybe its simpler and faster to implement direct pattern-matching
-}
{-# LANGUAGE BangPatterns, ViewPatterns #-}
module CSPM.Interpreter.PatternMatcher
(
 match
,tryMatchStrict
,tryMatchLazy
,boundNames
)
where

import Language.CSPM.AST as AST hiding (Bindings)
import CSPM.Interpreter.Types as Types
import CSPM.Interpreter.Bindings

import Data.Maybe
import qualified Data.Set as Set
import Control.Exception
import Data.Array.IArray as Array
import qualified Data.List as List

failedMatch :: Maybe Value
failedMatch = Nothing

typeError :: String -> Value -> Maybe Value
typeError x v = throwTypingError ("error in pattern-match : "++ x) Nothing $ Just v

-- todo make match strict !BangPattern
match :: Value -> Selector -> Maybe Value
match (VInt a) (IntSel b) = if a==b then return VUnit else failedMatch
match v        (IntSel _) = typeError "expecting Int" v

match (VBool True)  TrueSel = return VUnit
match (VBool False) TrueSel = failedMatch
match v             TrueSel = typeError "expecting Bool" v

match (VBool True)  FalseSel = failedMatch
match (VBool False) FalseSel = return VUnit
match v             FalseSel = typeError "expecting Bool" v

match x             SelectThis = return x

match (VChannel ch)  (ConstrSel ident)
  = if AST.uniqueIdentId ident == chanId ch then return VUnit else failedMatch
match (VConstructor (Types.Constructor i _ _))  (ConstrSel ident)
  = if AST.uniqueIdentId ident == i then return VUnit else failedMatch
match v             (ConstrSel c) = typeError ("expecting constructor " ++ show c) v
--  | DotSel Int Int Selector

match (VSet s)      (SingleSetSel b)
  = if not $ Set.null s then match (Set.findMin s) b else failedMatch
match v             (SingleSetSel _) = typeError "expecting a set" v

match (VSet s)      EmptySetSel
  =  if Set.null s then return VUnit else failedMatch
match v             EmptySetSel    = typeError "expecting a set" v

-- todo : really test this
match (VList l) p = case p of
  ListIthSel i next -> match (l !! i) next
  ListLengthSel 0 _next
    -> if null l then return VUnit else failedMatch
  ListLengthSel len next
    -> if length l == len then matchList len l next else failedMatch
  _ -> matchList (length l) l p


match t@(VTuple b)  (TupleLengthSel len next)
  = if length b == len then match t next else typeError "tuple wrong arity" t
match v             (TupleLengthSel _ n) = typeError "expecting tuple" v

match (VTuple b)    (TupleIthSel i next) = match (b !! i) next
match v             (TupleIthSel _ n) = typeError "expecting tuple" v

match (VDotTuple l) (DotSel i next) = match (l !! i) next
match v             (DotSel _ _) = typeError "expecting dot-tuple" v

match v p
  = throwInternalError ("hit catchall case of pattern-matcher :" ++ show (v,p))
      Nothing $ Just v

matchList :: Int -> [Value] -> Selector -> Maybe Value
matchList s !l !sel = case sel of
  SelectThis -> return $ VList l
  HeadSel next
    -> if null l then failedMatch else match (head l) next
  HeadNSel len next
    -> if s >= len
         then matchList len (take len l) next
         else failedMatch
  PrefixSel offset len next
    -> if s >= offset + len
         then matchList len (take len $ drop offset l) next
         else failedMatch
  TailSel next 
    -> if not $ null l then matchList (s-1) (tail l) next else failedMatch
  SliceSel offsetL offsetR next
    -> if s >= offsetL + offsetR
         then
           let
             newLen = s - offsetL -offsetR 
           in matchList newLen (take newLen $ drop offsetL l) next              
         else failedMatch
  SuffixSel offset len next
    -> if s >= offset + len
         then 
           let
             offsetLeft = s - offset - len
           in matchList len (take len $ drop offsetLeft l) next
         else failedMatch
  ListLengthSel len next
    -> if s == len then matchList s l next else failedMatch
  ListIthSel i next -> match (l !! i) next
  other -> throwTypingError ("matchList : not excpecting a List :" ++ show other)
    Nothing (Just $ VList l)


{-
If we force the result we first force the value we match against
and then we check all selectors !
We must be careful about lazyness/strictness here !
todo: maybe use ST-Transformer to fold over the array / do some optimisations
avoid detour via lists

-}

-- | tryMatchStrict returns Nothing or a new Binding
tryMatchStrict :: Bindings -> LPattern -> Value -> Maybe Bindings
tryMatchStrict !binds p !val = case unLabel p of
  VarPat ident -> Just $ bindIdent ident val binds

  Selector sel ident -> case match val sel of
     Nothing -> Nothing
     Just valPart -> case ident of
       Nothing -> Just binds
       Just i -> Just $ bindIdent i valPart binds

  Selectors selectorL identArray -> do
    values <- matchGroup val selectorL
    let 
      addBind b i = case identArray Array.! i of 
        Just n -> bindIdent n (values Array.! i) b
        Nothing -> b
    return $ List.foldl' addBind binds $ Array.indices identArray
  _ -> throwInternalError "PatternMatcher : unsupported Pattern in strict match"
         (Just $ srcLoc p) Nothing

-- | tryMatchLazy allways return a new Binding, but may throw a error when
-- | any value in the binding is forced 
-- | forcing one of the values causes all the selectors being tested

{-
todo : Fix THISBUG:
If we have Selectors which all do not bind a new Ident,
still should to force the value , so that we can detect a failing match
-}

tryMatchLazy :: Bindings -> LPattern -> Value -> Bindings
tryMatchLazy binds p@(unLabel -> VarPat ident) val
  = bindIdent ident val binds
tryMatchLazy binds p@(unLabel -> Selector sel ident) val
  = case ident of
      Just i -> bindIdent i valPart binds
      Nothing -> binds -- THISBUG
  where
    valPart = case match val sel of
      Just v -> v
      Nothing -> throwPatternMatchError "pattern-match failure" (Just $ srcLoc p) $ Just val

tryMatchLazy binds sel@(unLabel -> Selectors selectorss identArray) val
  = List.foldl' addBind binds $ Array.indices identArray
  where
    values = case matchGroup val selectorss of
      Just x -> x
      Nothing -> throwPatternMatchError "pattern-match failure"
         (Just $ srcLoc sel) $ Just val
    addBind b i = case identArray Array.! i of 
      Just n -> bindIdent n (values Array.! i) b
      Nothing -> b -- THISBUG
tryMatchLazy _ p v
  = throwInternalError "PatternMatcher : unsupported Pattern in lazyMatch"
      (Just $ srcLoc p) $ Just v

{-
If we force one of the values, we also have to force all
of the corresponding linear selectors !!
todo : for efficiency specialize this for small selectors
-}
matchGroup :: Value -> Array Int Selector -> Maybe (Array Int Value)
matchGroup val sel = do
  l <- mapM (match val) $ Array.elems sel
  return $ Array.listArray (Array.bounds sel) l


boundNames :: LPattern -> [LIdent]
boundNames pat = case unLabel pat of
  VarPat i -> [i]
  Selector _ Nothing -> []
  Selector _ (Just i) -> [i]
  x@(Selectors {}) -> catMaybes $ Array.elems $ idents x