module Test.Speculate.Expr.Match
( Binds
, fill
, assign
, assigning
, sub
, renameBy
, match
, match2
, matchWith
, unify
, unification
, isInstanceOf
, hasInstanceOf
, isCanonInstanceOf
, hasCanonInstanceOf
)
where
import Test.Speculate.Expr.Core
import Data.Typeable
import Data.List (find)
import Data.Maybe (isJust,fromMaybe)
import Data.Functor ((<$>))
import Test.Speculate.Utils
import Control.Monad ((>=>))
type Binds = [(String,Expr)]
findB :: String -> TypeRep -> Binds -> Maybe Expr
findB n t bs = snd <$> find (\(n',e) -> n' == n && typ e == t) bs
updateAssignments :: String -> Expr -> Binds -> Maybe Binds
updateAssignments s e = \bs ->
case findB s (typ e) bs of
Nothing -> Just ((s,e):bs)
Just e' -> if e' == e
then Just bs
else Nothing
fill :: Expr -> [Expr] -> Expr
fill e = fst . fill' e
where
fill' :: Expr -> [Expr] -> (Expr,[Expr])
fill' (e1 :$ e2) es = let (e1',es') = fill' e1 es
(e2',es'') = fill' e2 es'
in (e1' :$ e2', es'')
fill' (Var "" t) (e:es) | t == typ e = (e,es)
fill' e es = (e,es)
assign :: String -> Expr -> Expr -> Expr
assign n e (e1 :$ e2) = assign n e e1 :$ assign n e e2
assign n e (Var n' t) | t == typ e && n == n' = e
assign n e e1 = e1
assigning :: Expr -> Binds -> Expr
(e1 :$ e2) `assigning` as = (e1 `assigning` as) :$ (e2 `assigning` as)
(Var n t) `assigning` as = fromMaybe (Var n t) $ findB n t as
e `assigning` _ = e
sub :: Expr -> Expr -> Expr -> Expr
sub ef et = s
where
s e | e == ef = et
s (e1 :$ e2) = s e1 :$ s e2
s e = e
renameBy :: (String -> String) -> Expr -> Expr
renameBy f (e1 :$ e2) = renameBy f e1 :$ renameBy f e2
renameBy f (Var n t) = Var (f n) t
renameBy f e = e
match :: Expr -> Expr -> Maybe Binds
match = matchWith []
match2 :: (Expr,Expr) -> (Expr,Expr) -> Maybe Binds
match2 (e1,e2) (e3,e4) =
case matchWith [] e1 e3 of
Nothing -> Nothing
Just bs -> matchWith bs e2 e4
matchWith :: Binds -> Expr -> Expr -> Maybe Binds
matchWith bs e1' e2' = m e1' e2' bs
where
m :: Expr -> Expr -> Binds -> Maybe Binds
m e1 e2 | typ e1 /= typ e2 = const Nothing
m e1 (Var s t) = updateAssignments s e1
m (f1 :$ x1) (f2 :$ x2) = m f1 f2 >=> m x1 x2
m e1 e2 | e1 == e2 = Just
| otherwise = const Nothing
unify :: Expr -> Expr -> Maybe Expr
unify e1 e2 = (e1 `assigning`) <$> unification e1 e2
unification :: Expr -> Expr -> Maybe Binds
unification = naiveUnification
findBind :: Expr -> Expr -> Either Bool (String,Expr)
findBind e1 e2 | typ e1 /= typ e2 = Left False
| e1 == e2 = Left True
findBind (Var s t) e2 = Right (s,e2)
findBind e1 (Var s t) = Right (s,e1)
findBind (f1 :$ x1) (f2 :$ x2) = case findBind f1 f2 of
Left True -> findBind x1 x2
r -> r
findBind e1 e2 = Left (e1 == e2)
naiveUnification :: Expr -> Expr -> Maybe Binds
naiveUnification e1' e2' = uu e1' e2' []
where
uu :: Expr -> Expr -> Binds -> Maybe Binds
uu e1' e2' bs' =
case u e1' e2' bs' of
Nothing -> Nothing
Just (e1,e2,bs) ->
if e1' == e1 && e2' == e2
then Just bs
else uu e1 e2 bs
u :: Expr -> Expr -> Binds -> Maybe (Expr,Expr,Binds)
u e1 e2 bs =
case findBind e1 e2 of
Left False -> Nothing
Left True -> Just (e1,e2,bs)
Right (s,e) ->
if (Var s (typ e)) `isSub` e
then Nothing
else Just ( e1 `assigning` [(s,e)]
, e2 `assigning` [(s,e)]
, (s,e):[(s',e' `assigning` [(s,e)]) | (s',e') <- bs]
)
isInstanceOf :: Expr -> Expr -> Bool
e1 `isInstanceOf` e2 = isJust $ e1 `match` e2
hasInstanceOf :: Expr -> Expr -> Bool
e1 `hasInstanceOf` e2 | e1 `isInstanceOf` e2 = True
(e1f :$ e1x) `hasInstanceOf` e2 | e1f `hasInstanceOf` e2 ||
e1x `hasInstanceOf` e2 = True
_ `hasInstanceOf` _ = False
isCanonInstanceOf :: Expr -> Expr -> Bool
e1 `isCanonInstanceOf` e2 =
case e1 `match` e2 of
Nothing -> False
Just xs -> strictlyOrderedOn snd (sortOn fst xs)
hasCanonInstanceOf :: Expr -> Expr -> Bool
e1 `hasCanonInstanceOf` e2 | e1 `isCanonInstanceOf` e2 = True
(e1f :$ e1x) `hasCanonInstanceOf` e2 | e1f `hasCanonInstanceOf` e2 ||
e1x `hasCanonInstanceOf` e2 = True
_ `hasCanonInstanceOf` _ = False