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'
where
e1' = renameBy (++ "1") e1
e2' = renameBy (++ "2") e2
unification :: Expr -> Expr -> Maybe Binds
unification e1' e2' = u e1' e2' []
where
u :: Expr -> Expr -> Binds -> Maybe Binds
u e1 e2 | typ e1 /= typ e2 = const Nothing
u e1@(Var s1 t1) e2@(Var s2 t2) = updateAssignments s1 e2 >=> updateAssignments s2 e1
u e1 (Var s t) = updateAssignments s e1
u (Var s t) e2 = updateAssignments s e2
u (f1 :$ x1) (f2 :$ x2) = u f1 f2 >=> u x1 x2
u e1 e2 | e1 == e2 = Just
| otherwise = const Nothing
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