match :: (DefStore d, Match a) => d -> a -> Term -> Term -> IO (Either String a)
match def mtch t1 t2 =
    case (t1, t2) of
      -- handle the 'skip-cases' first
      (TypedTerm term _ _ _, _) -> match' term t2 -- logg "typed1" $ match' term t2
      (_, TypedTerm term _ _ _) -> match' t1 term -- logg "typed2" $ match' t1 term

      -- check for clash, handle constraints and definition expansion
      (ApplTerm f1 a1 _, _) ->
          case t2 of
            ApplTerm f2 a2 _
                -- 1a1.
                | f1 == f2 && isGood def f1 -> logg msg1a1 $ match' a1 a2
                -- 1a2., 1b.
                | otherwise -> logg msg1a21b addLocalConstraint

            -- eventually 2b.
            _ -> logg msg2b tryDefExpand2

      (TupleTerm l _, _) ->
          case t2 of
            TupleTerm l' _ | length l == length l' ->
                               logg msg1aT $ matchfold mtch $ zip l l'
                           | otherwise ->
                               logg "tclash" tupleClash
            -- eventually 2b.
            _ -> logg msg2bT tryDefExpand2

      -- 3.: add the mapping v->t2 to output
      (QualVar v, _) -> logg "mapped" $ addMapping v
      -- 2a.: follow the definition of pattern
      (QualOp _ (PolyId opid _ _) typ _ _ _, _) ->
          logg msg2a $ tryDefExpand1 (opid, typ)

      -- all other terms are not expected and accepted here
      _ -> return $ Left "match: unhandled term"

      where match' = match def mtch
            {- The definition expansion application case
            (for ApplTerm and TupleTerm) is handled uniformly -}
            tryDefExpand1 oi = case getTermDef t1 of
                                 Just t1' -> match' t1' t2
                                 _ | isMapable def oi -> addMapping oi
                                   | otherwise -> addLocalConstraint

            tryDefExpand2 = case getTermDef t2 of
                             Just t2' -> match' t1 t2'
                             _ -> addLocalConstraint

            getTermDef t = getTermOp t >>= getDefinition def
            addLocalConstraint
                -- Do not add constraints for equal terms
                | t1 == t2 = return $ Right mtch
                | otherwise = return $ Right $ addConstraint mtch t1 t2
            addMapping t = return $ Right $ addMatch mtch (toSC t) t2
            matchfold mtch' (x : l) = do
                    res <- uncurry (match def mtch') x
                    case res of
                      Right mtch'' -> matchfold mtch'' l
                      err -> return err
            matchfold mtch' [] = return $ Right mtch'
            -- clash = return $ Left $ "match: Clash for " ++ show (pretty (t1,t2))
            tupleClash = return $ Left $ "match: Clash for tuples "
                         ++ show (pretty (t1, t2))

            -- Logging stuff
            logg s a = do
                    let e = getEnv def
                    logMsg def $ text "Log" <+> text s
                               $++$ text "t1:" $+$ prettyInEnv e t1 $++$ text "t2:"
                               $+$ prettyInEnv e t2 $++$ text "==============="
                    a
            msg1a1 = "1a1: good same function"
            msg1a21b = "1a2, 1b: not good or not same function"
            msg1aT = "1aT: tuple: same tuple"
            msg2bT = "2bT:"
            msg2a = "2a: pattern constant"
            msg2b = "2b: term constant"


-- ----------------------- term tools -------------------------
match :: (DefStore d, Match a) => d -> a -> Term -> Term -> IO (Either String a)
match def mtch t1 t2 =
    case (t1, t2) of
      -- handle the 'skip-cases' first
      (TypedTerm term _ _ _, _) -> match' term t2 -- logg "typed1" $ match' term t2
      (_, TypedTerm term _ _ _) -> match' t1 term -- logg "typed2" $ match' t1 term

      -- check for clash, handle constraints and definition expansion
      (ApplTerm f1 a1 _, _) ->
          case t2 of
            ApplTerm f2 a2 _
                -- 1a1.
                | f1 == f2 && isGood def f1 -> logg msg1a1 $ match' a1 a2
                -- 1a2., 1b.
                | otherwise -> logg msg1a21b addLocalConstraint

            -- eventually 2b.
            _ -> logg msg2b tryDefExpand2

      (TupleTerm l _, _) ->
          case t2 of
            TupleTerm l' _ | length l == length l' ->
                               logg msg1aT $ matchfold mtch $ zip l l'
                           | otherwise ->
                               logg "tclash" tupleClash
            -- eventually 2b.
            _ -> logg msg2bT tryDefExpand2

      -- 3.: add the mapping v->t2 to output
      (QualVar v, _) -> logg "mapped" $ addMapping v
      -- 2a.: follow the definition of pattern
      (QualOp _ (PolyId opid _ _) typ _ _ _, _) ->
          logg msg2a $ tryDefExpand1 (opid, typ)

      -- all other terms are not expected and accepted here
      _ -> return $ Left "match: unhandled term"

      where match' = match def mtch
            {- The definition expansion application case
            (for ApplTerm and TupleTerm) is handled uniformly -}
            tryDefExpand1 oi = case getTermDef t1 of
                                 Just t1' -> match' t1' t2
                                 _ | isMapable def oi -> addMapping oi
                                   | otherwise -> addLocalConstraint

            tryDefExpand2 = case getTermDef t2 of
                             Just t2' -> match' t1 t2'
                             _ -> addLocalConstraint

            getTermDef t = getTermOp t >>= getDefinition def
            addLocalConstraint
                -- Do not add constraints for equal terms
                | t1 == t2 = return $ Right mtch
                | otherwise = return $ Right $ addConstraint mtch t1 t2
            addMapping t = return $ Right $ addMatch mtch (toSC t) t2
            matchfold mtch' (x : l) = do
                    res <- uncurry (match def mtch') x
                    case res of
                      Right mtch'' -> matchfold mtch'' l
                      err -> return err
            matchfold mtch' [] = return $ Right mtch'
            -- clash = return $ Left $ "match: Clash for " ++ show (pretty (t1,t2))
            tupleClash = return $ Left $ "match: Clash for tuples "
                         ++ show (pretty (t1, t2))

            -- Logging stuff
            logg s a = do
                    let e = getEnv def
                    logMsg def $ text "Log" <+> text s
                               $++$ text "t1:" $+$ prettyInEnv e t1 $++$ text "t2:"
                               $+$ prettyInEnv e t2 $++$ text "==============="
                    a
            msg1a1 = "1a1: good same function"
            msg1a21b = "1a2, 1b: not good or not same function"
            msg1aT = "1aT: tuple: same tuple"
            msg2bT = "2bT:"
            msg2a = "2a: pattern constant"
            msg2b = "2b: term constant"


-- ----------------------- term tools -------------------------
match def mtch t1 t2 =
    case (t1, t2) of
      -- handle the 'skip-cases' first
      (TypedTerm term _ _ _, _) -> match' term t2 -- logg "typed1" $ match' term t2
      (_, TypedTerm term _ _ _) -> match' t1 term -- logg "typed2" $ match' t1 term

      -- check for clash, handle constraints and definition expansion
      (ApplTerm f1 a1 _, _) ->
          case t2 of
            ApplTerm f2 a2 _
                -- 1a1.
                | f1 == f2 && isGood def f1 -> logg msg1a1 $ match' a1 a2
                -- 1a2., 1b.
                | otherwise -> logg msg1a21b addLocalConstraint

            -- eventually 2b.
            _ -> logg msg2b tryDefExpand2

      (TupleTerm l _, _) ->
          case t2 of
            TupleTerm l' _ | length l == length l' ->
                               logg msg1aT $ matchfold mtch $ zip l l'
                           | otherwise ->
                               logg "tclash" tupleClash
            -- eventually 2b.
            _ -> logg msg2bT tryDefExpand2

      -- 3.: add the mapping v->t2 to output
      (QualVar v, _) -> logg "mapped" $ addMapping v
      -- 2a.: follow the definition of pattern
      (QualOp _ (PolyId opid _ _) typ _ _ _, _) ->
          logg msg2a $ tryDefExpand1 (opid, typ)

      -- all other terms are not expected and accepted here
      _ -> return $ Left "match: unhandled term"

      where match' = match def mtch
            {- The definition expansion application case
            (for ApplTerm and TupleTerm) is handled uniformly -}
            tryDefExpand1 oi = case getTermDef t1 of
                                 Just t1' -> match' t1' t2
                                 _ | isMapable def oi -> addMapping oi
                                   | otherwise -> addLocalConstraint

            tryDefExpand2 = case getTermDef t2 of
                             Just t2' -> match' t1 t2'
                             _ -> addLocalConstraint

            getTermDef t = getTermOp t >>= getDefinition def
            addLocalConstraint
                -- Do not add constraints for equal terms
                | t1 == t2 = return $ Right mtch
                | otherwise = return $ Right $ addConstraint mtch t1 t2
            addMapping t = return $ Right $ addMatch mtch (toSC t) t2
            matchfold mtch' (x : l) = do
                    res <- uncurry (match def mtch') x
                    case res of
                      Right mtch'' -> matchfold mtch'' l
                      err -> return err
            matchfold mtch' [] = return $ Right mtch'
            -- clash = return $ Left $ "match: Clash for " ++ show (pretty (t1,t2))
            tupleClash = return $ Left $ "match: Clash for tuples "
                         ++ show (pretty (t1, t2))

            -- Logging stuff
            logg s a = do
                    let e = getEnv def
                    logMsg def $ text "Log" <+> text s
                               $++$ text "t1:" $+$ prettyInEnv e t1 $++$ text "t2:"
                               $+$ prettyInEnv e t2 $++$ text "==============="
                    a
            msg1a1 = "1a1: good same function"
            msg1a21b = "1a2, 1b: not good or not same function"
            msg1aT = "1aT: tuple: same tuple"
            msg2bT = "2bT:"
            msg2a = "2a: pattern constant"
            msg2b = "2b: term constant"


-- ----------------------- term tools -------------------------