diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -1,5 +1,15 @@
 # Changelog
 
+## 0.1.7.0
+
+- [incompatibility] with previous versions, CHR (and required code) moved to separate libs chr-*
+- [compatibility] with ghc 8.2.x
+
+## 0.1.6.8
+
+- [api] addition of replacement for TreeTrie required for CHR solving (gives x4 performance improvement), also forcing changes in uhc
+- [api] rewrite of scoped lookup/map
+
 ## 0.1.6.7
 
 ## 0.1.6.6
diff --git a/src/UHC/Util/AssocL.hs b/src/UHC/Util/AssocL.hs
--- a/src/UHC/Util/AssocL.hs
+++ b/src/UHC/Util/AssocL.hs
@@ -1,94 +1,6 @@
 module UHC.Util.AssocL
-    ( -- * Assoc list
-      Assoc, AssocL
-    , assocLMapElt, assocLMapKey
-    , assocLElts, assocLKeys
-    , assocLGroupSort
-    , assocLMapUnzip
-    , ppAssocL, ppAssocL'
-    , ppAssocLV, ppAssocLH
-    , ppCurlysAssocL
-    
-      -- * Utils
-    , combineToDistinguishedElts
+    ( module CHR.Data.AssocL
     )
   where
-import UHC.Util.Pretty
-import UHC.Util.Utils
-import Data.List
-import Data.Maybe
-import Data.Function
 
--------------------------------------------------------------------------------------------
---- AssocL
--------------------------------------------------------------------------------------------
-
-type Assoc k v = (k,v)
-type AssocL k v = [Assoc k v]
-
-ppAssocL' :: (PP k, PP v, PP s) => ([PP_Doc] -> PP_Doc) -> s -> AssocL k v -> PP_Doc
-ppAssocL' ppL sep al = ppL (map (\(k,v) -> pp k >|< sep >#< pp v) al)
-
-ppAssocL :: (PP k, PP v) => AssocL k v -> PP_Doc
-ppAssocL = ppAssocL' (ppBlock "[" "]" ",") ":"
-
-ppAssocLV :: (PP k, PP v) => AssocL k v -> PP_Doc
-ppAssocLV = ppAssocL' vlist ":"
-{-# INLINE ppAssocLV #-}
-
-ppAssocLH :: (PP k, PP v) => AssocL k v -> PP_Doc
-ppAssocLH = ppAssocL' (ppBlockH "[" "]" ", ") ":"
-{-# INLINE ppAssocLH #-}
-
--- | intended for parsing
-ppCurlysAssocL :: (k -> PP_Doc) -> (v -> PP_Doc) -> AssocL k v -> PP_Doc
-ppCurlysAssocL pk pv = ppCurlysCommasBlock . map (\(k,v) -> pk k >#< "=" >#< pv v)
-
-assocLMap :: (k -> v -> (k',v')) -> AssocL k v -> AssocL k' v'
-assocLMap f = map (uncurry f)
-{-# INLINE assocLMap #-}
-
-assocLMapElt :: (v -> v') -> AssocL k v -> AssocL k v'
-assocLMapElt f = assocLMap (\k v -> (k,f v))
-{-# INLINE assocLMapElt #-}
-
-assocLMapKey :: (k -> k') -> AssocL k v -> AssocL k' v
-assocLMapKey f = assocLMap (\k v -> (f k,v))
-{-# INLINE assocLMapKey #-}
-
-assocLMapUnzip :: AssocL k (v1,v2) -> (AssocL k v1,AssocL k v2)
-assocLMapUnzip l = unzip [ ((k,v1),(k,v2)) | (k,(v1,v2)) <- l ]
-
-assocLKeys :: AssocL k v -> [k]
-assocLKeys = map fst
-{-# INLINE assocLKeys #-}
-
-assocLElts :: AssocL k v -> [v]
-assocLElts = map snd
-{-# INLINE assocLElts #-}
-
-assocLGroupSort :: Ord k => AssocL k v -> AssocL k [v]
-assocLGroupSort = map (foldr (\(k,v) (_,vs) -> (k,v:vs)) (panic "UHC.Util.AssocL.assocLGroupSort" ,[])) . groupSortOn fst
-
--------------------------------------------------------------------------------------------
---- Utils: Combinations
--------------------------------------------------------------------------------------------
-
--- | Combine [[x1..xn],..,[y1..ym]] to [[x1..y1],[x2..y1],..,[xn..ym]].
---   Each element [xi..yi] is distinct based on the the key k in xi==(k,_)
-combineToDistinguishedElts :: Eq k => [AssocL k v] -> [AssocL k v]
-combineToDistinguishedElts = combineToDistinguishedEltsBy ((==) `on` fst)
-{-
-combineToDistinguishedElts []     = []
-combineToDistinguishedElts [[]]   = []
-combineToDistinguishedElts [x]    = map (:[]) x
-combineToDistinguishedElts (l:ls)
-  = combine l $ combineToDistinguishedElts ls
-  where combine l ls
-          = concatMap (\e@(k,_)
-                         -> mapMaybe (\ll -> maybe (Just (e:ll)) (const Nothing) $ lookup k ll)
-                                     ls
-                      ) l
-
--}
-{-# INLINE combineToDistinguishedElts #-}
+import CHR.Data.AssocL
diff --git a/src/UHC/Util/CHR/Base.hs b/src/UHC/Util/CHR/Base.hs
--- a/src/UHC/Util/CHR/Base.hs
+++ b/src/UHC/Util/CHR/Base.hs
@@ -69,11 +69,22 @@
   -- , CHRBuiltinSolvable(..)
   
   , CHRTrOpt(..)
+  
+  , IVar
+  
+  , VarToNmMp
+  , emptyVarToNmMp
+  
+  , NmToVarMp
+  , emptyNmToVarMp
   )
   where
 
 -- import qualified UHC.Util.TreeTrie as TreeTrie
 import           UHC.Util.VarMp
+import           UHC.Util.Lookup            (Lookup, Stacked, LookupApply)
+import qualified UHC.Util.Lookup            as Lk
+import qualified UHC.Util.Lookup.Stacked    as Lk
 import           Data.Word
 import           Data.Monoid
 import           Data.Typeable
@@ -92,175 +103,18 @@
 import           UHC.Util.Serialize
 import           UHC.Util.Substitutable
 
+import           CHR.Types.Core             hiding
+                                            ( IsCHRConstraint
+                                            , IsCHRGuard
+                                            , IsCHRBacktrackPrio
+                                            , IsCHRPrio
+                                            )
+import qualified CHR.Types.Core             as CHR
+
 import           UHC.Util.Debug
 
--------------------------------------------------------------------------------------------
---- CHRMatchHow
--------------------------------------------------------------------------------------------
 
--- | How to match, increasingly more binding is allowed
-data CHRMatchHow
-  = CHRMatchHow_Check               -- ^ equality check only
-  | CHRMatchHow_Match               -- ^ also allow one-directional (left to right) matching/binding of (meta)vars
-  | CHRMatchHow_MatchAndWait        -- ^ also allow giving back of global vars on which we wait
-  | CHRMatchHow_Unify               -- ^ also allow bi-directional matching, i.e. unification
-  deriving (Ord, Eq)
-
 -------------------------------------------------------------------------------------------
---- CHRMatchEnv
--------------------------------------------------------------------------------------------
-
--- | Context/environment required for matching itself
-data CHRMatchEnv k
-  = CHRMatchEnv
-      { {- chrmatchenvHow          :: !CHRMatchHow
-      , -} 
-        chrmatchenvMetaMayBind  :: !(k -> Bool)
-      }
-
-emptyCHRMatchEnv :: CHRMatchEnv x
-emptyCHRMatchEnv = CHRMatchEnv {- CHRMatchHow_Check -} (const True)
-
--------------------------------------------------------------------------------------------
---- Wait for var
--------------------------------------------------------------------------------------------
-
-type CHRWaitForVarSet s = Set.Set (VarLookupKey s)
-
--------------------------------------------------------------------------------------------
---- CHRMatcher, call back API used during matching
--------------------------------------------------------------------------------------------
-
-{-
-data CHRMatcherState subst k
-  = CHRMatcherState
-      { _chrmatcherstateVarLookup       :: !(StackedVarLookup subst)
-      , _chrmatcherstateWaitForVarSet   :: !(CHRWaitForVarSet subst)
-      , _chrmatcherstateEnv             :: !(CHRMatchEnv k)
-      }
-  deriving Typeable
--}
-type CHRMatcherState subst k = (StackedVarLookup subst, CHRWaitForVarSet subst, CHRMatchEnv k)
-
-mkCHRMatcherState :: StackedVarLookup subst -> CHRWaitForVarSet subst -> CHRMatchEnv k -> CHRMatcherState subst k
-mkCHRMatcherState s w e = (s, w, e)
--- mkCHRMatcherState s w e = CHRMatcherState s w e
-{-# INLINE mkCHRMatcherState #-}
-
-unCHRMatcherState :: CHRMatcherState subst k -> (StackedVarLookup subst, CHRWaitForVarSet subst, CHRMatchEnv k)
-unCHRMatcherState = id
--- unCHRMatcherState (CHRMatcherState s w e) = (s,w,e)
-{-# INLINE unCHRMatcherState #-}
-
--- | Failure of CHRMatcher
-data CHRMatcherFailure
-  = CHRMatcherFailure
-  | CHRMatcherFailure_NoBinding         -- ^ absence of binding
-
--- | Matching monad, keeping a stacked (pair) of subst (local + global), and a set of global variables upon which the solver has to wait in order to (possibly) match further/again
--- type CHRMatcher subst = StateT (StackedVarLookup subst, CHRWaitForVarSet subst) (Either ())
-type CHRMatcher subst = StateT (CHRMatcherState subst (VarLookupKey subst)) (Either CHRMatcherFailure)
-
--- instance (k ~ VarLookupKey subst) => MonadState (CHRMatcherState subst k) (CHRMatcher subst)
-
-chrmatcherstateVarLookup     = fst3l
-chrmatcherstateWaitForVarSet = snd3l
-chrmatcherstateEnv           = trd3l
-
-{-
-mkLabel ''CHRMatcherState
--}
-
--------------------------------------------------------------------------------------------
---- Common part w.r.t. variable lookup
--------------------------------------------------------------------------------------------
-
--- | Do the resolution part of a comparison, continuing with a function which can assume variable resolution has been done for the terms being compared
-chrMatchResolveCompareAndContinue
-  :: forall s .
-     ( VarLookup s
-     , VarLookupCmb s s
-     , Ord (VarLookupKey s)
-     , VarTerm (VarLookupVal s)
-     , ExtrValVarKey (VarLookupVal s) ~ VarLookupKey s
-     )
-  =>    CHRMatchHow                                                     -- ^ how to do the resolution
-     -> (VarLookupVal s -> VarLookupVal s -> CHRMatcher s ())           -- ^ succeed with successful varlookup continuation
-     -> VarLookupVal s                                                  -- ^ left/fst val
-     -> VarLookupVal s                                                  -- ^ right/snd val
-     -> CHRMatcher s ()
-chrMatchResolveCompareAndContinue how ok t1 t2
-  = cmp t1 t2
-  where cmp t1 t2 = do
-          menv <- getl chrmatcherstateEnv
-          case (varTermMbKey t1, varTermMbKey t2) of
-              (Just v1, Just v2) | v1 == v2                         -> chrMatchSuccess
-                                 | how == CHRMatchHow_Check         -> varContinue
-                                                                         (varContinue (waitv v1 >> waitv v2) (ok t1) v2)
-                                                                         (\t1 -> varContinue (waitt t1 >> waitv v2) (ok t1) v2)
-                                                                         v1
-                                 where waitv v = unless (chrmatchenvMetaMayBind menv v) $ chrMatchWait v
-                                       waitt = maybe (return ()) waitv . varTermMbKey
-              (Just v1, _      ) | how == CHRMatchHow_Check         -> varContinue (if maybind then chrMatchFail else chrMatchWait v1) (flip ok t2) v1
-                                 | how >= CHRMatchHow_Match && maybind
-                                                                    -> varContinue (chrMatchBind v1 t2) (flip ok t2) v1
-                                 | otherwise                        -> varContinue chrMatchFail (flip ok t2) v1
-                                 where maybind = chrmatchenvMetaMayBind menv v1
-              (_      , Just v2) | how == CHRMatchHow_Check         -> varContinue (if maybind then chrMatchFail else chrMatchWait v2) (ok t1) v2
-                                 | how == CHRMatchHow_MatchAndWait  -> varContinue (chrMatchWait v2) (ok t1) v2
-                                 | how == CHRMatchHow_Unify && maybind
-                                                                    -> varContinue (chrMatchBind v2 t1) (ok t1) v2
-                                 | otherwise                        -> varContinue chrMatchFail (ok t1) v2
-                                 where maybind = chrmatchenvMetaMayBind menv v2
-              _                                                     -> chrMatchFail -- ok t1 t2
-        varContinue = varlookupResolveAndContinueM varTermMbKey chrMatchSubst
-
--------------------------------------------------------------------------------------------
---- CHRCheckable
--------------------------------------------------------------------------------------------
-
--- | A Checkable participates in the reduction process as a guard, to be checked.
--- Checking is allowed to find/return substitutions for meta variables (not for global variables).
-class (CHREmptySubstitution subst, VarLookupCmb subst subst) => CHRCheckable env x subst where
-  chrCheck :: env -> subst -> x -> Maybe subst
-  chrCheck e s x = chrmatcherUnlift (chrCheckM e x) emptyCHRMatchEnv s
-
-  chrCheckM :: env -> x -> CHRMatcher subst ()
-  chrCheckM e x = chrmatcherLift $ \sg -> chrCheck e sg x
-
--------------------------------------------------------------------------------------------
---- CHRPrioEvaluatable
--------------------------------------------------------------------------------------------
-
--- | The type of value a prio representation evaluates to, must be Ord instance
-type family CHRPrioEvaluatableVal p :: *
-
--- | A PrioEvaluatable participates in the reduction process to indicate the rule priority, higher prio takes precedence
-class (Ord (CHRPrioEvaluatableVal x), Bounded (CHRPrioEvaluatableVal x)) => CHRPrioEvaluatable env x subst | x -> env subst where
-  -- | Reduce to a prio representation
-  chrPrioEval :: env -> subst -> x -> CHRPrioEvaluatableVal x
-  chrPrioEval _ _ _ = minBound
-
-  -- | Compare priorities
-  chrPrioCompare :: env -> (subst,x) -> (subst,x) -> Ordering
-  chrPrioCompare e (s1,x1) (s2,x2) = chrPrioEval e s1 x1 `compare` chrPrioEval e s2 x2
-  
-  -- | Lift prio val into prio
-  chrPrioLift :: CHRPrioEvaluatableVal x -> x
-
--------------------------------------------------------------------------------------------
---- Prio
--------------------------------------------------------------------------------------------
-
--- | Separate priority type, where minBound represents lowest prio, and compare sorts from high to low prio (i.e. high `compare` low == LT)
-newtype Prio = Prio {unPrio :: Word32}
-  deriving (Eq, Bounded, Num, Enum, Integral, Real)
-
-instance Ord Prio where
-  compare = flip compare `on` unPrio
-  {-# INLINE compare #-}
-  
--------------------------------------------------------------------------------------------
 --- Constraint API
 -------------------------------------------------------------------------------------------
 
@@ -273,8 +127,10 @@
       , Serialize c
       , TTKeyable c
       , IsConstraint c
-      , Ord c, Ord (TTKey c)
-      , PP c, PP (TTKey c)
+      , Ord c
+      , Ord (TTKey c)
+      , PP c
+      , PP (TTKey c)
       ) => IsCHRConstraint env c subst
 
 -------------------------------------------------------------------------------------------
@@ -309,207 +165,5 @@
       , PP (CHRPrioEvaluatableVal bp)
       -- , Num (CHRPrioEvaluatableVal bp)
       ) => IsCHRBacktrackPrio env bp subst
-
--- instance {-# OVERLAPPABLE #-} (CHREmptySubstitution subst, VarLookupCmb subst subst) => IsCHRBacktrackPrio env () subst
-
--------------------------------------------------------------------------------------------
---- What a constraint must be capable of
--------------------------------------------------------------------------------------------
-
--- | Different ways of solving
-data ConstraintSolvesVia
-  = ConstraintSolvesVia_Rule        -- ^ rewrite/CHR rules apply
-  | ConstraintSolvesVia_Solve       -- ^ solving involving finding of variable bindings (e.g. unification)
-  | ConstraintSolvesVia_Residual    -- ^ a leftover, residue
-  | ConstraintSolvesVia_Fail        -- ^ triggers explicit fail
-  | ConstraintSolvesVia_Succeed     -- ^ triggers explicit succes
-  deriving (Show, Enum, Eq, Ord)
-
-instance PP ConstraintSolvesVia where
-  pp = pp . show
-
--- | The things a constraints needs to be capable of in order to participate in solving
-class IsConstraint c where
-  -- | Requires solving? Or is just a residue...
-  cnstrRequiresSolve :: c -> Bool
-  cnstrRequiresSolve c = case cnstrSolvesVia c of
-    ConstraintSolvesVia_Residual -> False
-    _                            -> True
-  
-  cnstrSolvesVia :: c -> ConstraintSolvesVia
-  cnstrSolvesVia c | cnstrRequiresSolve c = ConstraintSolvesVia_Rule
-                   | otherwise            = ConstraintSolvesVia_Residual
-
--------------------------------------------------------------------------------------------
---- Tracing options, specific for CHR solvers
--------------------------------------------------------------------------------------------
-
-data CHRTrOpt
-  = CHRTrOpt_Lookup     -- ^ trie query
-  | CHRTrOpt_Stats      -- ^ various stats
-  deriving (Eq, Ord, Show)
--------------------------------------------------------------------------------------------
---- CHREmptySubstitution
--------------------------------------------------------------------------------------------
-
--- | Capability to yield an empty substitution.
-class CHREmptySubstitution subst where
-  chrEmptySubst :: subst
-
--------------------------------------------------------------------------------------------
---- CHRMatchable
--------------------------------------------------------------------------------------------
-
--- | The key of a substitution
-type family CHRMatchableKey subst :: *
-
-type instance CHRMatchableKey (StackedVarLookup subst) = CHRMatchableKey subst
-
--- | A Matchable participates in the reduction process as a reducable constraint.
--- Unification may be incorporated as well, allowing matching to be expressed in terms of unification.
--- This facilitates implementations of 'CHRBuiltinSolvable'.
-class (CHREmptySubstitution subst, VarLookupCmb subst subst, VarExtractable x, VarLookupKey subst ~ ExtrValVarKey x) => CHRMatchable env x subst where
-  -- | One-directional (1st to 2nd 'x') unify
-  chrMatchTo :: env -> subst -> x -> x -> Maybe subst
-  chrMatchTo env s x1 x2 = chrUnify CHRMatchHow_Match (emptyCHRMatchEnv {chrmatchenvMetaMayBind = (`Set.member` varFreeSet x1)}) env s x1 x2
-    -- where free = varFreeSet x1
-  
-  -- | One-directional (1st to 2nd 'x') unify
-  chrUnify :: CHRMatchHow -> CHRMatchEnv (VarLookupKey subst) -> env -> subst -> x -> x -> Maybe subst
-  chrUnify how menv e s x1 x2 = chrmatcherUnlift (chrUnifyM how e x1 x2) menv s
-  
-  -- | Match one-directional (from 1st to 2nd arg), under a subst, yielding a subst for the metavars in the 1st arg, waiting for those in the 2nd
-  chrMatchToM :: env -> x -> x -> CHRMatcher subst ()
-  chrMatchToM e x1 x2 = chrUnifyM CHRMatchHow_Match e x1 x2
-
-  -- | Unify bi-directional or match one-directional (from 1st to 2nd arg), under a subst, yielding a subst for the metavars in the 1st arg, waiting for those in the 2nd
-  chrUnifyM :: CHRMatchHow -> env -> x -> x -> CHRMatcher subst ()
-  chrUnifyM how e x1 x2 = getl chrmatcherstateEnv >>= \menv -> chrmatcherLift $ \sg -> chrUnify how menv e sg x1 x2
-
-  -- | Solve a constraint which is categorized as 'ConstraintSolvesVia_Solve'
-  chrBuiltinSolveM :: env -> x -> CHRMatcher subst ()
-  chrBuiltinSolveM e x = return () -- chrmatcherLift $ \sg -> chrBuiltinSolve e sg x
-
-instance {-# OVERLAPPABLE #-} (CHRMatchable env x subst) => CHRMatchable env (Maybe x) subst where
-  chrUnifyM how e (Just x1) (Just x2) = chrUnifyM how e x1 x2
-  chrUnifyM how e  Nothing   Nothing  = chrMatchSuccess
-  chrUnifyM how e _         _         = chrMatchFail
-
-instance {-# OVERLAPPABLE #-} (CHRMatchable env x subst) => CHRMatchable env [x] subst where
-  chrUnifyM how e x1 x2 | length x1 == length x2 = sequence_ $ zipWith (chrUnifyM how e) x1 x2
-  chrUnifyM how e _  _                           = chrMatchFail
-
--------------------------------------------------------------------------------------------
---- CHRMatcher API, part I
--------------------------------------------------------------------------------------------
-
--- | Unlift/observe (or run) a CHRMatcher
-chrmatcherUnlift :: (CHREmptySubstitution subst) => CHRMatcher subst () -> CHRMatchEnv (VarLookupKey subst) -> (subst -> Maybe subst)
-chrmatcherUnlift mtch menv s = do
-    (s,w) <- chrmatcherRun mtch menv s
-    if Set.null w then Just s else Nothing
-
--- | Lift into CHRMatcher
-chrmatcherLift :: (VarLookupCmb subst subst) => (subst -> Maybe subst) -> CHRMatcher subst ()
-chrmatcherLift f = do
-    [sl,sg] <- fmap unStackedVarLookup $ getl chrmatcherstateVarLookup -- gets (unStackedVarLookup . _chrmatcherstateVarLookup)
-    maybe chrMatchFail (\snew -> chrmatcherstateVarLookup =$: (snew |+>)) $ f sg
-
--- | Run a CHRMatcher
-chrmatcherRun' :: (CHREmptySubstitution subst) => (CHRMatcherFailure -> r) -> (subst -> CHRWaitForVarSet subst -> x -> r) -> CHRMatcher subst x -> CHRMatchEnv (VarLookupKey subst) -> StackedVarLookup subst -> r
-chrmatcherRun' fail succes mtch menv s = either
-    fail
-    ((\(x,ms) -> let (StackedVarLookup s, w, _) = unCHRMatcherState ms in succes (head s) w x))
-      $ flip runStateT (mkCHRMatcherState s Set.empty menv)
-      $ mtch
-
--- | Run a CHRMatcher
-chrmatcherRun :: (CHREmptySubstitution subst) => CHRMatcher subst () -> CHRMatchEnv (VarLookupKey subst) -> subst -> Maybe (subst, CHRWaitForVarSet subst)
-chrmatcherRun mtch menv s = chrmatcherRun' (const Nothing) (\s w _ -> Just (s,w)) mtch menv (StackedVarLookup [chrEmptySubst,s])
-
--------------------------------------------------------------------------------------------
---- CHRMatcher API, part II
--------------------------------------------------------------------------------------------
-
-chrMatchSubst :: CHRMatcher subst (StackedVarLookup subst)
-chrMatchSubst = getl chrmatcherstateVarLookup
-{-# INLINE chrMatchSubst #-}
-
-chrMatchBind :: forall subst k v . (VarLookupCmb subst subst, VarLookup subst, k ~ VarLookupKey subst, v ~ VarLookupVal subst) => k -> v -> CHRMatcher subst ()
-chrMatchBind k v = chrmatcherstateVarLookup =$: ((varlookupSingleton k v :: subst) |+>)
-{-# INLINE chrMatchBind #-}
-
-chrMatchWait :: (Ord k, k ~ VarLookupKey subst) => k -> CHRMatcher subst ()
-chrMatchWait k = chrMatchModifyWait (Set.insert k)
-{-# INLINE chrMatchWait #-}
-
-chrMatchSuccess :: CHRMatcher subst ()
-chrMatchSuccess = return ()
-{-# INLINE chrMatchSuccess #-}
-
--- | Normal CHRMatcher failure
-chrMatchFail :: CHRMatcher subst a
-chrMatchFail = throwError CHRMatcherFailure
-{-# INLINE chrMatchFail #-}
-
--- | CHRMatcher failure because a variable binding is missing
-chrMatchFailNoBinding :: CHRMatcher subst a
-chrMatchFailNoBinding = throwError CHRMatcherFailure_NoBinding
-{-# INLINE chrMatchFailNoBinding #-}
-
-chrMatchSucces :: CHRMatcher subst ()
-chrMatchSucces = return ()
-{-# INLINE chrMatchSucces #-}
-
-chrMatchModifyWait :: (CHRWaitForVarSet subst -> CHRWaitForVarSet subst) -> CHRMatcher subst ()
-chrMatchModifyWait f =
-  -- modify (\st -> st {_chrmatcherstateWaitForVarSet = f $ _chrmatcherstateWaitForVarSet st})
-  -- (chrmatcherstateWaitForVarSet =$:)
-  modify (\(s,w,e) -> (s,f w,e))
-{-# INLINE chrMatchModifyWait #-}
-
--- | Match one-directional (from 1st to 2nd arg), under a subst, yielding a subst for the metavars in the 1st arg, waiting for those in the 2nd
-chrMatchAndWaitToM :: CHRMatchable env x subst => Bool -> env -> x -> x -> CHRMatcher subst ()
-chrMatchAndWaitToM wait env x1 x2 = chrUnifyM (if wait then CHRMatchHow_MatchAndWait else CHRMatchHow_Match) env x1 x2
-
--------------------------------------------------------------------------------------------
---- CHRMatchable: instances
--------------------------------------------------------------------------------------------
-
--- TBD: move to other file...
-instance {-# OVERLAPPABLE #-} Ord (ExtrValVarKey ()) => VarExtractable () where
-  varFreeSet _ = Set.empty
-
-instance {-# OVERLAPPABLE #-} (Ord (ExtrValVarKey ()), CHREmptySubstitution subst, VarLookupCmb subst subst, VarLookupKey subst ~ ExtrValVarKey ()) => CHRMatchable env () subst where
-  chrUnifyM _ _ _ _ = chrMatchSuccess
-
--------------------------------------------------------------------------------------------
---- Prio: instances
--------------------------------------------------------------------------------------------
-
-instance Show Prio where
-  show = show . unPrio
-
-instance PP Prio where
-  pp = pp . unPrio
-
--------------------------------------------------------------------------------------------
---- CHRPrioEvaluatable: instances
--------------------------------------------------------------------------------------------
-
-type instance CHRPrioEvaluatableVal () = Prio
-
-{-
-instance {-# OVERLAPPABLE #-} Ord x => CHRPrioEvaluatable env x subst where
-  -- chrPrioEval _ _ _ = minBound
-  chrPrioCompare _ (_,x) (_,y) = compare x y
--}
-
-{-
-instance {-# OVERLAPPABLE #-} CHRPrioEvaluatable env () subst where
-  chrPrioLift _ = ()
-  chrPrioEval _ _ _ = minBound
-  chrPrioCompare _ _ _ = EQ
--}
 
 
diff --git a/src/UHC/Util/CHR/GTerm.hs b/src/UHC/Util/CHR/GTerm.hs
deleted file mode 100644
--- a/src/UHC/Util/CHR/GTerm.hs
+++ /dev/null
@@ -1,14 +0,0 @@
--------------------------------------------------------------------------------------------
---- Generic terms describing constraints, providing parsing and interpretation to AST of your choice
--------------------------------------------------------------------------------------------
-
-module UHC.Util.CHR.GTerm
-  ( module UHC.Util.CHR.GTerm.AST
-  , module UHC.Util.CHR.GTerm.Parser
-  )
-  where
-
-import           UHC.Util.CHR.GTerm.AST
-import           UHC.Util.CHR.GTerm.Parser
-
-
diff --git a/src/UHC/Util/CHR/GTerm/AST.hs b/src/UHC/Util/CHR/GTerm/AST.hs
deleted file mode 100644
--- a/src/UHC/Util/CHR/GTerm/AST.hs
+++ /dev/null
@@ -1,85 +0,0 @@
--------------------------------------------------------------------------------------------
---- Generic terms describing constraints, providing interpretation to AST of your choice
--------------------------------------------------------------------------------------------
-
-module UHC.Util.CHR.GTerm.AST
-  ( GTm(..)
-  
-  , GTermAs(..)
-  
-  , gtermasFail
-  )
-  where
-
-import           Data.Char
-import           Data.Typeable
-import           GHC.Generics
-import           Control.Monad.Except
-
-import           UHC.Util.Pretty as PP
-import           UHC.Util.Utils
-
--------------------------------------------------------------------------------------------
---- Term language/AST
--------------------------------------------------------------------------------------------
-
--- | Terms
-data GTm
-  = GTm_Var     String                  -- ^ variable (to be substituted)
-  | GTm_Int     Integer                 -- ^ int value (for arithmetic)
-  | GTm_Str     String                  -- ^ string value
-  | GTm_Con     String [GTm]            -- ^ general term structure
-  | GTm_Nil                             -- ^ special case: list nil
-  | GTm_Cns     GTm GTm                 -- ^ special case: list cons
-  deriving (Show, Eq, Ord, Typeable, Generic)
-
-instance PP GTm where
-  pp (GTm_Var v        ) = pp v -- "v" >|< v
-  pp (GTm_Con c []     ) = pp c
-  pp (GTm_Con c@(h:_) [a1,a2])
-    | not (isAlpha h)    = ppParens $ a1 >#< c >#< a2
-  pp (GTm_Con c as     ) = ppParens $ c >#< ppSpaces as
-  pp (GTm_Nil          ) = pp "[]"
-  pp (GTm_Cns h t      ) = "[" >|< h >#< ":" >#< t >|< "]"
-  pp (GTm_Int i        ) = pp i
-  pp (GTm_Str s        ) = pp $ show s
-
--------------------------------------------------------------------------------------------
---- Term interpretation in context of CHR
--------------------------------------------------------------------------------------------
-
--- | Interpretation monad, which is partial
-type GTermAsM = Either PP_Doc
-
--- | Term interpretation in context of CHR
-class GTermAs cnstr guard bprio prio tm
-  | cnstr -> guard bprio prio tm
-  , guard -> cnstr bprio prio tm
-  , bprio -> cnstr guard prio tm
-  , prio -> cnstr guard bprio tm
-  , tm -> cnstr guard bprio prio
-  where
-  --
-  asTm :: GTm -> GTermAsM tm
-  -- | as list, if matches/possible. Only to be invoked for GTm_Cns 
-  asTmList :: GTm -> GTermAsM ([tm], Maybe tm)
-  asTmList (GTm_Cns h    GTm_Nil     ) = asTm h >>= \h -> return ([h], Nothing)
-  asTmList (GTm_Cns h t@(GTm_Cns _ _)) = asTm h >>= \h -> asTmList t >>= \(t,mt) -> return ((h:t),mt)
-  asTmList (GTm_Cns h t              ) = asTm h >>= \h -> asTm     t >>= \t -> return ([h], Just t)
-  asTmList _                           = panic "GTermAs.asTmList: should not happen, not intended to be called with non GTm_Cns"
-  --
-  asHeadConstraint :: GTm -> GTermAsM cnstr
-  --
-  asBodyConstraint :: GTm -> GTermAsM cnstr
-  --
-  asGuard :: GTm -> GTermAsM guard
-  --
-  asHeadBacktrackPrio :: GTm -> GTermAsM bprio
-  --
-  asAltBacktrackPrio :: GTm -> GTermAsM bprio
-  --
-  asRulePrio :: GTm -> GTermAsM prio
-
--- | Fail the interpretation
-gtermasFail :: GTm -> String -> GTermAsM a
-gtermasFail t m = throwError $ "GTerm interpretation failure" >-< indent 2 ("why :" >#< m >-< "term:" >#< t)
diff --git a/src/UHC/Util/CHR/GTerm/Parser.hs b/src/UHC/Util/CHR/GTerm/Parser.hs
deleted file mode 100644
--- a/src/UHC/Util/CHR/GTerm/Parser.hs
+++ /dev/null
@@ -1,147 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-
-module UHC.Util.CHR.GTerm.Parser
-  ( parseFile
-  )
-  where
-
-import qualified Data.Set as Set
-
-import           Control.Monad
-
-import           UU.Parsing
-import           UU.Scanner
-import           UU.Scanner.TokenParser
-import           UU.Scanner.Token
-
-import           UHC.Util.ParseUtils
-import           UHC.Util.ScanUtils
-import           UHC.Util.Pretty
-
-import           UHC.Util.CHR.Rule
-import           UHC.Util.CHR.GTerm.AST
-
--------------------------------------------------------------------------------------------
---- Scanning options for CHR parsing
--------------------------------------------------------------------------------------------
-
--- | Scanning options for rule parser
-scanOpts :: ScanOpts
-scanOpts
-  =  defaultScanOpts
-        {   scoKeywordsTxt      =   Set.fromList []
-        ,   scoKeywordsOps      =   Set.fromList ["\\", "=>", "==>", "<=>", ".", ":", "::", "@", "|", "\\/", "?"]
-        ,   scoOpChars          =   Set.fromList "!#$%&*+/<=>?@\\^|-:.~"
-        ,   scoSpecChars        =   Set.fromList "()[],`"
-        }
-
--------------------------------------------------------------------------------------------
---- Parse interface
--------------------------------------------------------------------------------------------
-
--- | Parse a file as a CHR spec + queries
-parseFile :: GTermAs c g bp rp tm => FilePath -> IO (Either PP_Doc ([Rule c g bp rp], [c]))
-parseFile f = do
-    toks <- scanFile
-      (Set.toList $ scoKeywordsTxt scanOpts)
-      (Set.toList $ scoKeywordsOps scanOpts)
-      (Set.toList $ scoSpecChars scanOpts)
-      (Set.toList $ scoOpChars scanOpts)
-      f
-    (prog, query) <- parseIOMessage show pProg toks
-    return $ do
-      prog <- forM prog $ \r@(Rule {ruleHead=hcs, ruleGuard=gs, ruleBodyAlts=as, ruleBacktrackPrio=mbp, rulePrio=mrp}) -> do
-        mbp <- maybe (return Nothing) (fmap Just . asHeadBacktrackPrio) mbp
-        mrp <- maybe (return Nothing) (fmap Just . asRulePrio) mrp
-        hcs <- forM hcs asHeadConstraint
-        gs  <- forM gs  asGuard
-        as  <- forM as $ \a@(RuleBodyAlt {rbodyaltBacktrackPrio=mbp, rbodyaltBody=bs}) -> do
-          mbp <- maybe (return Nothing) (fmap Just . asAltBacktrackPrio) mbp
-          bs  <- forM bs asBodyConstraint
-          return $ a {rbodyaltBacktrackPrio=mbp, rbodyaltBody=bs}
-        return $ r {ruleHead=hcs, ruleGuard=gs, ruleBodyAlts=as, ruleBacktrackPrio=mbp, rulePrio=mrp}
-      query <- forM query asHeadConstraint
-      return (prog,query)
-
--------------------------------------------------------------------------------------------
---- Program is set of rules + optional queries
--------------------------------------------------------------------------------------------
-
-type Pr p = PlainParser Token p
-
--- | CHR Program = rules + optional queries
-pProg :: Pr ([Rule GTm GTm GTm GTm], [GTm])
-pProg =
-    pRules <+> pQuery
-  where
-    pR = pPre <**>
-           ( pHead <**>
-               (   (   (\(g,b) h pre -> pre $ g $ mkR h (length h) b) <$ pKey "<=>"
-                   <|> (\(g,b) h pre -> pre $ g $ mkR h 0          b) <$ (pKey "=>" <|> pKey "==>")
-                   ) <*> pBody
-               <|> (   (\hr (g,b) hk pre -> pre $ g $ mkR (hr ++ hk) (length hr) b)
-                       <$ pKey "\\" <*> pHead <* pKey "<=>" <*> pBody
-                   )
-               )
-           )
-       where pPre = (\(bp,rp) lbl -> lbl . bp . rp) 
-                    <$> (pParens ((,) <$> (flip (=!) <$> pTm_Var <|> pSucceed id)
-                                      <*  pComma
-                                      <*> (flip (=!!) <$> pTm <|> pSucceed id)
-                                 ) <* pKey "::" <|> pSucceed (id,id)
-                        )
-                    <*> ((@=) <$> (pConid <|> pVarid) <* pKey "@" <|> pSucceed id)
-             pHead = pList1Sep pComma pTm_App
-             pGrd = flip (=|) <$> pList1Sep pComma pTm_Op <* pKey "|" <|> pSucceed id
-             pBody = pGrd <+> pBodyAlts
-             pBodyAlts = pListSep (pKey "\\/") pBodyAlt
-             pBodyAlt
-               = (\pre b -> pre $ b /\ [])
-                 <$> (flip (\!) <$> pTm <* pKey "::" <|> pSucceed id)
-                 <*> pList1Sep pComma pTm_Op
-             mkR h len b = Rule h len [] b Nothing Nothing Nothing
-
-    pRules = pList (pR <* pKey ".")
-
-    pQuery = concat <$> pList (pKey "?" *> pList1Sep pComma pTm_Op <* pKey ".")
-    
-    pTm
-      = pTm_Op
-
-    pTm_Op
-      = pTm_App <**>
-          (   (\o r l -> GTm_Con o [l,r]) <$> pOp <*> pTm_App
-          <|> pSucceed id
-          )
-      where pOp
-              =   pConsym
-              <|> pVarsym
-              <|> pKey "`" *> pConid <* pKey "`"
-              <|> pCOLON
-
-    pTm_App
-      =   GTm_Con <$> pConid <*> pList1 pTm_Base
-      <|> (\o l r -> GTm_Con o [l,r]) <$> pParens pVarsym <*> pTm_Base <*> pTm_Base
-      <|> pTm_Base
-
-    pTm_Base
-      =   pTm_Var
-      <|> (GTm_Int . read) <$> pInteger
-      <|> GTm_Str <$> pString
-      <|> flip GTm_Con [] <$> pConid
-      <|> pParens pTm
-      <|> pPacked (pKey "[") (pKey "]")
-            (   pTm_App <**>
-                  (   (\t h -> foldr1 GTm_Cns         (h:t)) <$ pCOLON   <*> pList1Sep  pCOLON    pTm_App
-                  <|> (\t h -> foldr  GTm_Cns GTm_Nil (h:t)) <$ pKey "," <*> pList1Sep (pKey ",") pTm_App
-                  <|> pSucceed (`GTm_Cns` GTm_Nil)
-                  )
-            <|> pSucceed GTm_Nil
-            )
-
-    pTm_Var
-      = GTm_Var <$> pVarid
-
-    pCOLON = pKey ":"
-
-
diff --git a/src/UHC/Util/CHR/Key.hs b/src/UHC/Util/CHR/Key.hs
--- a/src/UHC/Util/CHR/Key.hs
+++ b/src/UHC/Util/CHR/Key.hs
@@ -11,7 +11,7 @@
   )
   where
 
-import UHC.Util.TreeTrie
+import           UHC.Util.TreeTrie
 
 -------------------------------------------------------------------------------------------
 --- TTKeyable
diff --git a/src/UHC/Util/CHR/Rule.hs b/src/UHC/Util/CHR/Rule.hs
--- a/src/UHC/Util/CHR/Rule.hs
+++ b/src/UHC/Util/CHR/Rule.hs
@@ -41,7 +41,6 @@
   )
   where
 
--- import qualified UHC.Util.TreeTrie as TreeTrie
 import           UHC.Util.CHR.Base
 import           UHC.Util.VarMp
 import           UHC.Util.Utils
@@ -137,11 +136,10 @@
           ppChr l = ppSpaces l -- vlist l -- ppCurlysBlock
 
 type instance TTKey (Rule cnstr guard bprio prio) = TTKey cnstr
--- type instance TreeTrie.TrTrKey (Rule cnstr guard bprio prio) = TTKey cnstr
 
 instance (TTKeyable cnstr) => TTKeyable (Rule cnstr guard bprio prio) where
   toTTKey' o chr = toTTKey' o $ head $ ruleHead chr
-
+  
 -------------------------------------------------------------------------------------------
 --- Existentially quantified Rule representations to allow for mix of arbitrary universes
 -------------------------------------------------------------------------------------------
diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/AST.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/AST.hs
deleted file mode 100644
--- a/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/AST.hs
+++ /dev/null
@@ -1,466 +0,0 @@
-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
-
-{-| Simple term language with some builtin guards and predicates 
- -}
-
-module UHC.Util.CHR.Solve.TreeTrie.Examples.Term.AST
-  ( Tm(..)
-  , C(..)
-  , G(..)
-  -- , B(..)
-  , P(..)
-  , POp(..)
-  , E
-  , S
-  
-  , Var
-  )
-  where
-
-import           UHC.Util.VarLookup
-import           UHC.Util.Substitutable
-import           UHC.Util.TreeTrie
-import           UHC.Util.Pretty as PP
-import           UHC.Util.Serialize
-import           UHC.Util.CHR.Key
-import           UHC.Util.CHR.Base
-import           UHC.Util.CHR.Rule
-import           UHC.Util.Utils
-import           UHC.Util.AssocL
-import           UHC.Util.Lens
-import           UHC.Util.CHR.GTerm
-import           Data.Typeable
-import           Data.Maybe
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.List as List
-import           Control.Monad
-import           Control.Monad.IO.Class
-import           Control.Applicative
-import qualified UHC.Util.CHR.Solve.TreeTrie.Mono as M
-import qualified UHC.Util.CHR.Solve.TreeTrie.MonoBacktrackPrio as MBP
-
-import           UHC.Util.Debug
-
-
-type Var = String -- Int
-
-data Key
-  = Key_Int     !Int            
-  | Key_Var     !Var            
-  | Key_Str     !String   
-  | Key_Lst
-  | Key_Op      !POp   
-  | Key_Con     !String   
-  deriving (Eq, Ord, Show)
-
-instance PP Key where
-  pp (Key_Int i) = "ki" >|< ppParens i
-  pp (Key_Var v) = "kv" >|< ppParens v
-  pp (Key_Str s) = "ks" >|< ppParens s
-  pp (Key_Lst  ) = pp "kl"
-  pp (Key_Op  o) = "ko" >|< ppParens o
-  pp (Key_Con s) = "kc" >|< ppParens s
-
--- | Terms
-data Tm
-  = Tm_Var Var              -- ^ variable (to be substituted)
-  | Tm_Int Int              -- ^ int value (for arithmetic)
-  | Tm_Str String
-  | Tm_Bool Bool            -- ^ bool value
-  | Tm_Con String [Tm]      -- ^ general term structure
-  | Tm_Lst [Tm] (Maybe Tm)  -- ^ special case: list with head segment and term tail
-  | Tm_Op  POp    [Tm]      -- ^ interpretable (when solving) term structure
-  deriving (Show, Eq, Ord, Typeable, Generic)
-
-{-
-tmIsVar :: Tm -> Maybe Var
-tmIsVar (Tm_Var v) = Just v
-tmIsVar _          = Nothing
--}
-
-instance VarTerm Tm where
-  varTermMbKey (Tm_Var v) = Just v
-  varTermMbKey _          = Nothing
-  varTermMkKey            = Tm_Var
-
-instance PP Tm where
-  pp (Tm_Var v        ) = pp v -- "v" >|< v
-  pp (Tm_Con c []     ) = pp c
-  pp (Tm_Con c as     ) = ppParens $ c >#< ppSpaces as
-  pp (Tm_Lst h mt     ) = let l = ppBracketsCommas h in maybe l (\t -> ppParens $ l >#< ":" >#< t) mt
-  pp (Tm_Op  o [a    ]) = ppParens $ o >#< a
-  pp (Tm_Op  o [a1,a2]) = ppParens $ a1 >#< o >#< a2
-  pp (Tm_Int i        ) = pp i
-  pp (Tm_Str s        ) = pp $ show s
-  pp (Tm_Bool b       ) = pp b
-
-instance Serialize Tm
-
--- | Constraint
-data C
-  = C_Con String [Tm]
-  | CB_Eq Tm Tm          -- ^ builtin: unification
-  | CB_Ne Tm Tm          -- ^ builtin: non unification
-  | CB_Fail              -- ^ explicit fail
-  deriving (Show, Eq, Ord, Typeable, Generic)
-
-instance PP C where
-  pp (C_Con c as) = c >#< ppSpaces as
-  pp (CB_Eq x y ) = "unify" >#< ppSpaces [x,y]
-  pp (CB_Ne x y ) = "not-unify" >#< ppSpaces [x,y]
-  pp (CB_Fail   ) = pp "fail"
-
-instance Serialize C
-
--- | Guard
-data G
-  = G_Eq Tm Tm          -- ^ check for equality
-  | G_Ne Tm Tm          -- ^ check for inequality
-  | G_Tm Tm             -- ^ determined by arithmetic evaluation
-  deriving (Show, Typeable, Generic)
-
-instance PP G where
-  pp (G_Eq x y) = "is-eq" >#< ppParensCommas [x,y]
-  pp (G_Ne x y) = "is-ne" >#< ppParensCommas [x,y]
-  pp (G_Tm t  ) = "eval"  >#< ppParens t
-
-instance Serialize G
-
-type instance TrTrKey Tm = Key
-type instance TrTrKey C = Key
-type instance TTKey Tm = Key
-type instance TTKey C = Key
-
-type instance TrTrKey (Maybe x) = TTKey x
-
-{-
-instance (TTKeyable x, Key ~ TTKey (Maybe x)) => TTKeyable (Maybe x) where
-  toTTKeyParentChildren' o Nothing  = (TT1K_One $ Key_Con "Noth", ttkChildren [])
-  toTTKeyParentChildren' o (Just x) = (TT1K_One $ Key_Con "Just", ttkChildren [toTTKey' o x])
--}
-
-instance TTKeyable Tm where
-  toTTKeyParentChildren' o (Tm_Var v) | ttkoptsVarsAsWild o = (TT1K_Any, ttkChildren [])
-                                      | otherwise           = (TT1K_One $ Key_Var v, ttkChildren [])
-  toTTKeyParentChildren' o (Tm_Int i) = (TT1K_One $ Key_Int i, ttkChildren [])
-  toTTKeyParentChildren' o (Tm_Str s) = (TT1K_One $ Key_Str s, ttkChildren [])
-  toTTKeyParentChildren' o (Tm_Bool i) = (TT1K_One $ Key_Int $ fromEnum i, ttkChildren [])
-  toTTKeyParentChildren' o (Tm_Con c as) = (TT1K_One $ Key_Str c, ttkChildren $ map (toTTKey' o) as)
-  toTTKeyParentChildren' o (Tm_Lst h mt) = (TT1K_One $ Key_Lst  , ttkChildren $ {- [toTTKey' o mt] ++ -} map (toTTKey' o) h) -- map (toTTKey' o) $ maybeToList mt ++ h)
-  toTTKeyParentChildren' o (Tm_Op op as) = (TT1K_One $ Key_Op op, ttkChildren $ map (toTTKey' o) as)
-
-instance TTKeyable C where
-  -- Only necessary for non-builtin constraints
-  toTTKeyParentChildren' o (C_Con c as) = (TT1K_One $ Key_Str c, ttkChildren $ map (toTTKey' o) as)
-
-type E = ()
-
--- | Binary operator
-data POp
-  = 
-    -- binary
-    PBOp_Add
-  | PBOp_Sub
-  | PBOp_Mul
-  | PBOp_Mod
-  | PBOp_Lt
-  | PBOp_Le
-  
-    -- unary
-  | PUOp_Abs
-  deriving (Eq, Ord, Show, Generic)
-
-instance PP POp where
-  pp PBOp_Add = pp "+"
-  pp PBOp_Sub = pp "-"
-  pp PBOp_Mul = pp "*"
-  pp PBOp_Mod = pp "mod"
-  pp PBOp_Lt  = pp "<"
-  pp PBOp_Le  = pp "<="
-  pp PUOp_Abs = pp "abs"
-
-newtype P
-  = P_Tm Tm
-  deriving (Eq, Ord, Show, Generic)
-
-instance PP P where
-  pp (P_Tm t) = pp t
-
-instance Serialize POp
-
-instance Serialize P
-
-instance Bounded P where
-  minBound = P_Tm $ Tm_Int $ fromIntegral $ unPrio $ minBound
-  maxBound = P_Tm $ Tm_Int $ fromIntegral $ unPrio $ maxBound
-
-type S = Map.Map Var Tm
-
-type instance VarLookupKey S = Var
-type instance VarLookupVal S = Tm
-
-instance PP S where
-  pp = ppAssocLV . Map.toList
-
-type instance ExtrValVarKey G = Var
-type instance ExtrValVarKey C = Var
-type instance ExtrValVarKey Tm = Var
-type instance ExtrValVarKey P = Var
-
-type instance CHRMatchableKey S = Key
-
-instance VarLookup S where
-  varlookupWithMetaLev _ = Map.lookup
-  varlookupKeysSetWithMetaLev _ = Map.keysSet
-  varlookupSingletonWithMetaLev _ = Map.singleton
-  varlookupEmpty = Map.empty
-
-instance VarLookupCmb S S where
-  (|+>) = Map.union
-
-instance VarUpdatable S S where
-  varUpd s = Map.map (s `varUpd`) -- (|+>)
-
-instance VarUpdatable Tm S where
-  s `varUpd` t = case fromJust $ varlookupResolveVal varTermMbKey t s <|> return t of
-      Tm_Con c as -> Tm_Con c $ s `varUpd` as
-      Tm_Lst h mt -> Tm_Lst (s `varUpd` h) (s `varUpd` mt)
-      Tm_Op  o as -> Tm_Op  o $ s `varUpd` as
-      t -> t
-
-instance VarUpdatable P S where
-  s `varUpd` p = case p of
-    P_Tm t -> P_Tm (s `varUpd` t)
-
-instance VarUpdatable G S where
-  s `varUpd` G_Eq x y = G_Eq (s `varUpd` x) (s `varUpd` y)
-  s `varUpd` G_Ne x y = G_Ne (s `varUpd` x) (s `varUpd` y)
-  s `varUpd` G_Tm x   = G_Tm (s `varUpd` x)
-
-instance VarUpdatable C S where
-  s `varUpd` c = case c of
-    C_Con c as -> C_Con c $ map (s `varUpd`) as
-    CB_Eq x y  -> CB_Eq (s `varUpd` x) (s `varUpd` y)
-    CB_Ne x y  -> CB_Ne (s `varUpd` x) (s `varUpd` y)
-    c          -> c
-
-instance VarExtractable Tm where
-  varFreeSet (Tm_Var v) = Set.singleton v
-  varFreeSet (Tm_Con _ as) = Set.unions $ map varFreeSet as
-  varFreeSet (Tm_Lst h mt) = Set.unions $ map varFreeSet $ maybeToList mt ++ h
-  varFreeSet (Tm_Op  _ as) = Set.unions $ map varFreeSet as
-  varFreeSet _ = Set.empty
-
-instance VarExtractable G where
-  varFreeSet (G_Eq x y) = Set.unions [varFreeSet x, varFreeSet y]
-  varFreeSet (G_Ne x y) = Set.unions [varFreeSet x, varFreeSet y]
-  varFreeSet (G_Tm x  ) = varFreeSet x
-
-instance VarExtractable C where
-  varFreeSet (C_Con _ as) = Set.unions $ map varFreeSet as
-  varFreeSet (CB_Eq x y ) = Set.unions [varFreeSet x, varFreeSet y]
-  varFreeSet _            = Set.empty
-
-instance VarExtractable P where
-  varFreeSet (P_Tm t) = varFreeSet t
-
-instance CHREmptySubstitution S where
-  chrEmptySubst = Map.empty
-
-instance IsConstraint C where
-  cnstrSolvesVia (C_Con _ _) = ConstraintSolvesVia_Rule
-  cnstrSolvesVia (CB_Eq _ _) = ConstraintSolvesVia_Solve
-  cnstrSolvesVia (CB_Ne _ _) = ConstraintSolvesVia_Solve
-  cnstrSolvesVia (CB_Fail  ) = ConstraintSolvesVia_Fail
-
-instance IsCHRGuard E G S where
-
-instance IsCHRConstraint E C S where
-
-instance IsCHRPrio E P S where
-
-instance IsCHRBacktrackPrio E P S where
-
-instance CHRCheckable E G S where
-  chrCheckM e g =
-    case g of
-      G_Eq t1 t2 -> chrUnifyM CHRMatchHow_Check e t1 t2
-      G_Ne t1 t2 -> do
-        menv <- getl chrmatcherstateEnv
-        s <- getl chrmatcherstateVarLookup
-        chrmatcherRun'
-          (\e -> case e of {CHRMatcherFailure -> chrMatchSuccess; _ -> chrMatchFail})
-          (\_ _ _ -> chrMatchFail)
-          (chrCheckM e (G_Eq t1 t2)) menv s
-      G_Tm t -> do
-        e <- tmEval t
-        case e of
-          Tm_Bool True -> chrMatchSuccess
-          _            -> chrMatchFail
-
-instance CHRMatchable E Tm S where
-  chrUnifyM how e t1 t2 = case (t1, t2) of
-      (Tm_Con c1 as1, Tm_Con c2 as2) | c1 == c2                 -> chrUnifyM how e as1 as2
-      (Tm_Lst (h1:t1) mt1, Tm_Lst (h2:t2) mt2)                  -> chrUnifyM how e h1 h2 >> chrUnifyM how e (Tm_Lst t1 mt1) (Tm_Lst t2 mt2)
-      (Tm_Lst [] (Just t1), l2@(Tm_Lst {}))                     -> chrUnifyM how e t1 l2
-      (l1@(Tm_Lst {}), Tm_Lst [] (Just t2))                     -> chrUnifyM how e l1 t2
-      (Tm_Lst [] mt1, Tm_Lst [] mt2)                            -> chrUnifyM how e mt1 mt2
-      (Tm_Op  o1 as1, Tm_Op  o2 as2) | how < CHRMatchHow_Unify && o1 == o2
-                                                                -> chrUnifyM how e as1 as2
-      (Tm_Op  o1 as1, t2           ) | how == CHRMatchHow_Unify -> tmEvalOp o1 as1 >>= \t1 -> chrUnifyM how e t1 t2
-      (t1           , Tm_Op  o2 as2) | how == CHRMatchHow_Unify -> tmEvalOp o2 as2 >>= \t2 -> chrUnifyM how e t1 t2
-      (Tm_Int i1    , Tm_Int i2    ) | i1 == i2                 -> chrMatchSuccess
-      (Tm_Str s1    , Tm_Str s2    ) | s1 == s2                 -> chrMatchSuccess
-      (Tm_Bool b1   , Tm_Bool b2   ) | b1 == b2                 -> chrMatchSuccess
-      _                                                         -> chrMatchResolveCompareAndContinue how (chrUnifyM how e) t1 t2
-{-
-  chrUnifyM how e t1 t2 = do
-      menv <- getl chrmatcherstateEnv
-      case (t1, t2) of
-        (Tm_Con c1 as1, Tm_Con c2 as2) | c1 == c2 && length as1 == length as2 
-                                                                          -> sequence_ (zipWith (chrUnifyM how e) as1 as2)
---        (Tm_Lst h1 mt1, Tm_Lst h2 mt2)                                    -> chrUnifyM how e h1 h2 >> chrUnifyM how e mt1 mt2
-        (Tm_Op  o1 as1, Tm_Op  o2 as2) | how < CHRMatchHow_Unify && o1 == o2 && length as1 == length as2 
-                                                                          -> sequence_ (zipWith (chrUnifyM how e) as1 as2)
-        (Tm_Op  o1 as1, t2           ) | how == CHRMatchHow_Unify         -> evop o1 as1 >>= \t1 -> chrUnifyM how e t1 t2
-        (t1           , Tm_Op  o2 as2) | how == CHRMatchHow_Unify         -> evop o2 as2 >>= \t2 -> chrUnifyM how e t1 t2
-        (Tm_Int i1    , Tm_Int i2    ) | i1 == i2                         -> chrMatchSuccess
-        (Tm_Bool b1   , Tm_Bool b2   ) | b1 == b2                         -> chrMatchSuccess
-        (Tm_Var v1    , Tm_Var v2    ) | v1 == v2                         -> chrMatchSuccess
-                                       | how == CHRMatchHow_Check         -> varContinue
-                                                                               (varContinue (waitv v1 >> waitv v2) (chrUnifyM how e t1) v2)
-                                                                               (\t1 -> varContinue (waitt t1 >> waitv v2) (\t2 -> chrUnifyM how e t1 t2) v2)
-                                                                               v1
-                                       where waitv v = unless (chrmatchenvMetaMayBind menv v) $ chrMatchWait v
-                                             waitt (Tm_Var v) = waitv v
-                                             waitt  _         = return ()
-        (Tm_Var v1    , t2           ) | how == CHRMatchHow_Check         -> varContinue (if maybind then chrMatchFail else chrMatchWait v1) (\t1 -> chrUnifyM how e t1 t2) v1
-                                       | how >= CHRMatchHow_Match && maybind
-                                                                          -> varContinue (chrMatchBind v1 t2) (\t1 -> chrUnifyM how e t1 t2) v1
-                                       | otherwise                        -> varContinue chrMatchFail {- chrMatchFailNoBinding -} (\t1 -> chrUnifyM how e t1 t2) v1
-                                       where maybind = chrmatchenvMetaMayBind menv v1
-        (t1           , Tm_Var v2    ) | how == CHRMatchHow_Check         -> varContinue (if maybind then chrMatchFail else chrMatchWait v2) (chrUnifyM how e t1) v2
-                                       | how == CHRMatchHow_MatchAndWait  -> varContinue (chrMatchWait v2) (chrUnifyM how e t1) v2
-                                       | how == CHRMatchHow_Unify && maybind
-                                                                          -> varContinue (chrMatchBind v2 t1) (chrUnifyM how e t1) v2
-                                       | otherwise                        -> varContinue chrMatchFail {- chrMatchFailNoBinding -} (chrUnifyM how e t1) v2
-                                       where maybind = chrmatchenvMetaMayBind menv v2
-        _                                                                 -> chrMatchFail
-    where
-      varContinue = varlookupResolveAndContinueM varTermMbKey chrMatchSubst
-      evop = tmEvalOp
-      ev = tmEval
--}
-
-tmEval :: Tm -> CHRMatcher S Tm
-tmEval x = case x of
-          Tm_Int _    -> return x
-          Tm_Var v    -> varlookupResolveAndContinueM varTermMbKey chrMatchSubst chrMatchFailNoBinding tmEval v
-          Tm_Op  o xs -> tmEvalOp o xs
-          _           -> chrMatchFail
-
-tmEvalOp :: POp -> [Tm] -> CHRMatcher S Tm
-tmEvalOp o xs = do
-          xs <- forM xs tmEval 
-          case (o, xs) of
-            (PUOp_Abs, [Tm_Int x]) -> ret $ abs x
-            (PBOp_Add, [Tm_Int x, Tm_Int y]) -> ret $ x + y
-            (PBOp_Sub, [Tm_Int x, Tm_Int y]) -> ret $ x - y
-            (PBOp_Mul, [Tm_Int x, Tm_Int y]) -> ret $ x * y
-            (PBOp_Mod, [Tm_Int x, Tm_Int y]) -> ret $ x `mod` y
-            (PBOp_Lt , [Tm_Int x, Tm_Int y]) -> retb $ x < y
-            (PBOp_Le , [Tm_Int x, Tm_Int y]) -> retb $ x <= y
-        where ret  x = return $ Tm_Int  x
-              retb x = return $ Tm_Bool x
-
-instance CHRMatchable E C S where
-  chrUnifyM how e c1 c2 = do
-    case (c1, c2) of
-      (C_Con c1 as1, C_Con c2 as2) | c1 == c2 && length as1 == length as2 
-        -> sequence_ (zipWith (chrUnifyM how e) as1 as2)
-      _ -> chrMatchFail
-  chrBuiltinSolveM e b = case b of
-    CB_Eq x y -> chrUnifyM CHRMatchHow_Unify e x y
-    CB_Ne x y -> do
-        menv <- getl chrmatcherstateEnv
-        s <- getl chrmatcherstateVarLookup
-        chrmatcherRun' (\_ -> chrMatchSuccess) (\_ _ _ -> chrMatchFail) (chrBuiltinSolveM e (CB_Eq x y)) menv s
-
-instance CHRMatchable E P S where
-  chrUnifyM how e p1 p2 = do
-    case (p1, p2) of
-      (P_Tm   t1     , P_Tm   t2     ) -> chrUnifyM how e t1  t2
-
-type instance CHRPrioEvaluatableVal Tm = Prio
-
-instance CHRPrioEvaluatable E Tm S where
-  chrPrioEval e s t = case chrmatcherRun' (\_ -> Tm_Int $ fromIntegral $ unPrio $ (minBound :: Prio)) (\_ _ x -> x) (tmEval t) emptyCHRMatchEnv (StackedVarLookup [s]) of
-    Tm_Int i -> fromIntegral i
-    t        -> minBound
-  chrPrioLift = Tm_Int . fromIntegral
-
-type instance CHRPrioEvaluatableVal P = Prio
-
-instance CHRPrioEvaluatable E P S where
-  chrPrioEval e s p = case p of
-    P_Tm t -> chrPrioEval e s t
-  chrPrioLift = P_Tm . chrPrioLift
-
-
---------------------------------------------------------
-
-instance GTermAs C G P P Tm where
-  asHeadConstraint t = case t of
-    GTm_Con c a -> forM a asTm >>= (return . C_Con c)
-    t -> gtermasFail t "not a constraint"
-
-  asBodyConstraint t = case t of
-    GTm_Con "Fail" [] -> return CB_Fail
-    GTm_Con o [a,b] | isJust o' -> do
-        a <- asTm a
-        b <- asTm b
-        return $ fromJust o' a b
-      where o' = List.lookup o [("==", CB_Eq), ("/=", CB_Ne)]
-    t -> asHeadConstraint t
-
-  asGuard t = case t of
-    GTm_Con o [a,b] | isJust o' -> do
-        a <- asTm a
-        b <- asTm b
-        return $ fromJust o' a b
-      where o' = List.lookup o [("==", G_Eq), ("/=", G_Ne)]
-    t -> fmap G_Tm $ asTm t
-    
-  asHeadBacktrackPrio = fmap P_Tm . asTm
-
-  asAltBacktrackPrio = asHeadBacktrackPrio
-  asRulePrio = asHeadBacktrackPrio
-
-  asTm t = case t of
-    GTm_Con "True" [] -> return $ Tm_Bool True
-    GTm_Con "False" [] -> return $ Tm_Bool False
-    GTm_Con o [a] | isJust o' -> do
-        a <- asTm a
-        return $ Tm_Op (fromJust o') [a]
-      where o' = List.lookup o [("Abs", PUOp_Abs)]
-    GTm_Con o [a,b] | isJust o' -> do
-        a <- asTm a
-        b <- asTm b
-        return $ Tm_Op (fromJust o') [a,b]
-      where o' = List.lookup o [("+", PBOp_Add), ("-", PBOp_Sub), ("*", PBOp_Mul), ("Mod", PBOp_Mod), ("<", PBOp_Lt), ("<=", PBOp_Le)]
-    GTm_Con c a -> forM a asTm >>= (return . Tm_Con c)
-    GTm_Var v -> return $ Tm_Var v
-    GTm_Str v -> return $ Tm_Str v
-    GTm_Int i -> return $ Tm_Int (fromInteger i)
-    GTm_Nil   -> return $ Tm_Lst [] Nothing
-    t@(GTm_Cns _ _) -> asTmList t >>= (return . uncurry Tm_Lst)
-    -- t -> gtermasFail t "not a term"
-
---------------------------------------------------------
--- leq example, backtrack prio specific
-
-instance MBP.IsCHRSolvable E C G P P S
-
-instance MBP.MonoBacktrackPrio C G P P S E IO
-
diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/Main.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/Main.hs
deleted file mode 100644
--- a/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/Main.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-module UHC.Util.CHR.Solve.TreeTrie.Examples.Term.Main
-  ( RunOpt(..)
-  , Verbosity(..)
-
-  , runFile
-  )
-  where
-
-import           Data.Maybe
-import           System.IO
-import           Data.Time.Clock.POSIX
-import           Control.Monad
-import           Control.Monad.IO.Class
-import           Control.Monad.State.Class
-import qualified Data.Set as Set
-
-import           UU.Parsing
-import           UU.Scanner
-
-import           UHC.Util.Substitutable
-import           UHC.Util.Pretty
-import           UHC.Util.CHR.Rule
-import           UHC.Util.CHR.GTerm.Parser
-import           UHC.Util.CHR.Solve.TreeTrie.MonoBacktrackPrio as MBP
-import           UHC.Util.CHR.Solve.TreeTrie.Examples.Term.AST
--- import           UHC.Util.CHR.Solve.TreeTrie.Examples.Term.Parser
-import           UHC.Util.CHR.Solve.TreeTrie.Visualizer
-
-data RunOpt
-  = RunOpt_DebugTrace               -- ^ include debugging trace in output
-  | RunOpt_SucceedOnLeftoverWork    -- ^ left over unresolvable (non residue) work is also a successful result
-  | RunOpt_SucceedOnFailedSolve     -- ^ failed solve is considered also a successful result, with the failed constraint as a residue
-  | RunOpt_WriteVisualization       -- ^ write visualization (html file) to disk
-  | RunOpt_Verbosity Verbosity
-  deriving (Eq)
-
-mbRunOptVerbosity :: [RunOpt] -> Maybe Verbosity
-mbRunOptVerbosity []                       = Nothing
-mbRunOptVerbosity (RunOpt_Verbosity v : _) = Just v
-mbRunOptVerbosity (_                  : r) = mbRunOptVerbosity r
-
--- | Run file with options
-runFile :: [RunOpt] -> FilePath -> IO ()
-runFile runopts f = do
-    -- scan, parse
-    msg $ "READ " ++ f    
-    mbParse <- parseFile f
-    case mbParse of
-      Left e -> putPPLn e
-      Right (prog, query) -> do
-        let sopts = defaultCHRSolveOpts
-                      { chrslvOptSucceedOnLeftoverWork = RunOpt_SucceedOnLeftoverWork `elem` runopts
-                      , chrslvOptSucceedOnFailedSolve  = RunOpt_SucceedOnFailedSolve  `elem` runopts
-                      }
-            mbp :: CHRMonoBacktrackPrioT C G P P S E IO (SolverResult S)
-            mbp = do
-              -- print program
-              liftIO $ putPPLn $ "Rules" >-< indent 2 (vlist $ map pp prog)
-              -- freshen query vars
-              query <- slvFreshSubst Set.empty query >>= \s -> return $ s `varUpd` query
-              -- print query
-              liftIO $ putPPLn $ "Query" >-< indent 2 (vlist $ map pp query)
-              mapM_ addRule prog
-              mapM_ addConstraintAsWork query
-              -- solve
-              liftIO $ msg $ "SOLVE " ++ f
-              r <- chrSolve sopts ()
-              let verbosity = maximum $ [Verbosity_Quiet] ++ maybeToList (mbRunOptVerbosity runopts) ++ (if RunOpt_DebugTrace `elem` runopts then [Verbosity_ALot] else [])
-              ppSolverResult verbosity r >>= \sr -> liftIO $ putPPLn $ "Solution" >-< indent 2 sr
-              if (RunOpt_WriteVisualization `elem` runopts)
-                then
-                  do
-                    (CHRGlobState{_chrgstTrace = trace}, _) <- get
-                    time <- liftIO getPOSIXTime
-                    let fileName = "visualization-" ++ show (round time) ++ ".html"
-                    liftIO $ writeFile fileName (showPP $ chrVisualize query trace)
-                    liftIO $ msg "VISUALIZATION"
-                    liftIO $ putStrLn $ "Written visualization as " ++ fileName
-                else (return ())
-              return r
-        runCHRMonoBacktrackPrioT (emptyCHRGlobState) (emptyCHRBackState {- _chrbstBacktrackPrio=0 -}) {- 0 -} mbp
-
-        -- done
-        msg $ "DONE " ++ f
-    
-  where
-    msg m = putStrLn $ "---------------- " ++ m ++ " ----------------"
-    -- dummy = undefined :: Rule C G P P
-
--- | run some test programs
-mainTerm = do
-  forM_
-      [
-        "typing2"
-      -- , "queens"
-      -- , "leq"
-      -- , "var"
-      -- , "ruleprio"
-      -- , "backtrack3"
-      -- , "unify"
-      -- , "antisym"
-      ] $ \f -> do
-    let f' = "test/" ++ f ++ ".chr"
-    runFile
-      [ RunOpt_SucceedOnLeftoverWork
-      , RunOpt_DebugTrace
-      ] f'
-  
-
-{-
--}
diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Internal/Shared.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Internal/Shared.hs
--- a/src/UHC/Util/CHR/Solve/TreeTrie/Internal/Shared.hs
+++ b/src/UHC/Util/CHR/Solve/TreeTrie/Internal/Shared.hs
@@ -17,7 +17,8 @@
   , initWorkTime
   
   , WorkKey
-  , Work(..)
+  , Work'(..)
+  , Work
   
   , SolveStep'(..)
   , SolveTrace'
@@ -28,19 +29,21 @@
   where
 
 import           UHC.Util.CHR.Key
-import           UHC.Util.TreeTrie as TreeTrie
+import           UHC.Util.TreeTrie          as TreeTrie
 
-import           UHC.Util.Pretty as Pretty
+import           UHC.Util.Pretty            as Pretty
 import           UHC.Util.AssocL
 
-import qualified Data.Map as Map
+import qualified Data.Map                   as Map
 
 -------------------------------------------------------------------------------------------
 --- Choice of Trie structure
 -------------------------------------------------------------------------------------------
 
-type CHRTrie' k v = TreeTrie.TreeTrie (TTKey k) v
-type CHRTrieKey v = TreeTrie.TreeTrieKey (TTKey v)
+type CHRTrie'  k v = TreeTrie.TreeTrie  (TTKey k) v
+-- type CHRTrie2' k v = TreeTrie2.TreeTrie (TreeTrie2.TrTrKey k) v
+type CHRTrieKey  v = TreeTrie.TreeTrieKey  (TTKey v)
+-- type CHRTrieKey2 v = TreeTrie2.TreeTrieKey (TTKey v)
 
 -- | Obtain key for use in rule
 chrToKey :: (TTKeyable x, TrTrKey x ~ TTKey x) => x -> CHRTrieKey x
@@ -57,7 +60,7 @@
 -------------------------------------------------------------------------------------------
 
 -- | Convenience alias for key into CHR store
-type CHRKey v = CHRTrieKey v
+type CHRKey  v = CHRTrieKey v
 
 -------------------------------------------------------------------------------------------
 --- WorkTime, the time/history counter for solver work
@@ -73,12 +76,12 @@
 --- Solver work and/or residual (non)work
 -------------------------------------------------------------------------------------------
 
-type WorkKey       v = CHRKey v
+type WorkKey       v = CHRKey  v
 
 -- | A chunk of work to do when solving, a constraint + sequence nr
-data Work c
+data Work' k c
   = Work
-      { workKey     :: WorkKey c                    -- ^ the key into the CHR store
+      { workKey     :: k                            -- ^ the key into the CHR store
       , workCnstr   :: !c                           -- ^ the constraint to be reduced
       , workTime    :: WorkTime                     -- ^ the timestamp identification at which the work was added
       }
@@ -90,13 +93,16 @@
       }
   | Work_Fail
 
-type instance TTKey (Work c) = TTKey c
+type Work  c = Work' (WorkKey  c) c
 
-instance Show (Work c) where
+type instance TTKey       (Work' k c) = TTKey       c
+
+instance Show (Work' k c) where
   show _ = "SolveWork"
 
-instance (PP (TTKey c), PP c) => PP (Work c) where
-  pp (Work         k c t) = ppParens k >|< "@" >|< t >#< c
+instance (PP k, PP c) => PP (Work' k c) where
+  pp (Work {workKey=k, workCnstr=c, workTime=t})
+                          = ppParens k >|< "@" >|< t >#< c
   pp (Work_Residue   c  ) = pp                           c
   pp (Work_Solve     c  ) = pp                           c
   pp (Work_Fail         ) = pp "fail"
diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs
--- a/src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs
+++ b/src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs
@@ -200,8 +200,8 @@
 -- | (Class alias) API for solving requirements
 class ( IsCHRConstraint env c s
       , IsCHRGuard env g s
-      , VarLookupCmb s s
-      , VarUpdatable s s
+      , LookupApply s s
+      -- , VarUpdatable s s
       , CHREmptySubstitution s
       , TrTrKey c ~ TTKey c
       ) => IsCHRSolvable env c g s
@@ -494,7 +494,7 @@
   :: ( CHREmptySubstitution s
      , CHRMatchable env c s
      , CHRCheckable env g s
-     , VarLookupCmb s s
+     , LookupApply s s
      )
      => env -> StoredCHR c g -> [c] -> Maybe s
 slvMatch env chr cnstrs
diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/MonoBacktrackPrio.hs b/src/UHC/Util/CHR/Solve/TreeTrie/MonoBacktrackPrio.hs
deleted file mode 100644
--- a/src/UHC/Util/CHR/Solve/TreeTrie/MonoBacktrackPrio.hs
+++ /dev/null
@@ -1,1163 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, UndecidableInstances, NoMonomorphismRestriction, MultiParamTypeClasses, TemplateHaskell, FunctionalDependencies #-}
-
--------------------------------------------------------------------------------------------
---- CHR solver
--------------------------------------------------------------------------------------------
-
-{-|
-Under development (as of 20160218).
-
-Solver is:
-- Monomorphic, i.e. the solver is polymorph but therefore can only work on 1 type of constraints, rules, etc.
-- Knows about variables for which substitutions can be found, substitutions are part of found solutions.
-- Backtracking (on variable bindings/substitutions), multiple solution alternatives are explored.
-- Found rules are applied in an order described by priorities associated with rules. Priorities can be dynamic, i.e. depend on terms in rules.
-
-See
-
-"A Flexible Search Framework for CHR", Leslie De Koninck, Tom Schrijvers, and Bart Demoen.
-http://link.springer.com/10.1007/978-3-540-92243-8_2
--}
-
-module UHC.Util.CHR.Solve.TreeTrie.MonoBacktrackPrio
-  ( Verbosity(..)
-
-  , CHRGlobState(..)
-  , emptyCHRGlobState
-  
-  , CHRBackState(..)
-  , emptyCHRBackState
-  
-  , emptyCHRStore
-  
-  , CHRMonoBacktrackPrioT
-  , MonoBacktrackPrio
-  , runCHRMonoBacktrackPrioT
-  
-  , addRule
-  
-  , addConstraintAsWork
-  
-  , SolverResult(..)
-  , ppSolverResult
-  
-  , CHRSolveOpts(..)
-  , defaultCHRSolveOpts
-  
-  , StoredCHR
-  , storedChrRule'
-  
-  , chrSolve
-  
-  , slvFreshSubst
-  
-  , getSolveTrace
-  
-{-
-  ( CHRStore
-  , emptyCHRStore
-  
-  , chrStoreFromElems
-  , chrStoreUnion
-  , chrStoreUnions
-  , chrStoreSingletonElem
-  , chrStoreToList
-  , chrStoreElems
-  
-  , ppCHRStore
-  , ppCHRStore'
-  
-  , SolveStep'(..)
-  , SolveStep
-  , SolveTrace
-  , ppSolveTrace
-  
-  , SolveState
-  , emptySolveState
-  , solveStateResetDone
-  , chrSolveStateDoneConstraints
-  , chrSolveStateTrace
--}
-  
-  , IsCHRSolvable(..)
-{-
-  , chrSolve'
-  , chrSolve''
-  , chrSolveM
-  )
--}
-  )
-  where
-
-import           UHC.Util.CHR.Base
-import           UHC.Util.CHR.Key
-import           UHC.Util.CHR.Rule
-import           UHC.Util.CHR.Solve.TreeTrie.Internal.Shared
-import           UHC.Util.Substitutable
-import           UHC.Util.VarLookup
-import           UHC.Util.VarMp
-import           UHC.Util.AssocL
-import           UHC.Util.Fresh
-import           UHC.Util.TreeTrie as TreeTrie
-import qualified Data.Set as Set
-import qualified Data.PQueue.Prio.Min as Que
-import qualified Data.Map as Map
-import qualified Data.IntMap.Strict as IntMap
-import qualified Data.IntSet as IntSet
-import qualified Data.Sequence as Seq
-import           Data.List as List
-import           Data.Typeable
--- import           Data.Data
-import           Data.Maybe
-import           UHC.Util.Pretty as Pretty
-import           UHC.Util.Serialize
-import           Control.Monad
-import           Control.Monad.Except
-import           Control.Monad.State.Strict
-import           UHC.Util.Utils
-import           UHC.Util.Lens
-import           Control.Monad.LogicState
-
-import           UHC.Util.Debug
-
--------------------------------------------------------------------------------------------
---- Verbosity
--------------------------------------------------------------------------------------------
-
-data Verbosity
-  = Verbosity_Quiet         -- default
-  | Verbosity_Normal
-  | Verbosity_ALot
-  deriving (Eq, Ord, Show, Enum, Typeable)
-
--------------------------------------------------------------------------------------------
---- A CHR as stored
--------------------------------------------------------------------------------------------
-
--- | Index into table of CHR's, allowing for indirection required for sharing of rules by search for different constraints in the head
-type CHRInx = Int
-
--- | Index into rule and head constraint
-data CHRConstraintInx =
-  CHRConstraintInx -- {-# UNPACK #-}
-    { chrciInx :: !CHRInx
-    , chrciAt  :: !Int
-    }
-  deriving (Eq, Ord, Show)
-
-instance PP CHRConstraintInx where
-  pp (CHRConstraintInx i j) = i >|< "." >|< j
-
--- | A CHR as stored in a CHRStore, requiring additional info for efficiency
-data StoredCHR c g bp p
-  = StoredCHR
-      { _storedHeadKeys  :: ![CHRTrieKey c]                        -- ^ the keys corresponding to the head of the rule
-      , _storedChrRule   :: !(Rule c g bp p)                          -- ^ the rule
-      , _storedChrInx    :: !CHRInx                                -- ^ index of constraint for which is keyed into store
-      -- , storedKeys      :: ![Maybe (CHRKey c)]                  -- ^ keys of all constraints; at storedChrInx: Nothing
-      -- , storedIdent     :: !(UsedByKey c)                       -- ^ the identification of a CHR, used for propagation rules (see remark at begin)
-      }
-  deriving (Typeable)
-storedChrRule' :: StoredCHR c g bp p -> Rule c g bp p
-storedChrRule' = _storedChrRule
-
-type instance TTKey (StoredCHR c g bp p) = TTKey c
-
-{-
-instance (TTKeyable (Rule c g bp p)) => TTKeyable (StoredCHR c g bp p) where
-  toTTKey' o schr = toTTKey' o $ storedChrRule schr
-
--- | The size of the simplification part of a CHR
-storedSimpSz :: StoredCHR c g bp p -> Int
-storedSimpSz = ruleSimpSz . storedChrRule
-{-# INLINE storedSimpSz #-}
--}
-
--- | A CHR store is a trie structure
-data CHRStore cnstr guard bprio prio
-  = CHRStore
-      { _chrstoreTrie    :: CHRTrie' cnstr [CHRConstraintInx]                       -- ^ map from the search key of a rule to the index into tabl
-      , _chrstoreTable   :: IntMap.IntMap (StoredCHR cnstr guard bprio prio)      -- ^ (possibly multiple) rules for a key
-      }
-  deriving (Typeable)
-
-emptyCHRStore :: CHRStore cnstr guard bprio prio
-emptyCHRStore = CHRStore TreeTrie.empty IntMap.empty
-
--------------------------------------------------------------------------------------------
---- Store holding work, split up in global and backtrackable part
--------------------------------------------------------------------------------------------
-
-type WorkInx = WorkTime
-
-type WorkInxSet = IntSet.IntSet
-
-data WorkStore cnstr
-  = WorkStore
-      { _wkstoreTrie     :: CHRTrie' cnstr [WorkInx]                -- ^ map from the search key of a constraint to index in table
-      , _wkstoreTable    :: IntMap.IntMap (Work cnstr)      -- ^ all the work ever entered
-      }
-  deriving (Typeable)
-
-emptyWorkStore :: WorkStore cnstr
-emptyWorkStore = WorkStore TreeTrie.empty IntMap.empty
-
-data WorkQueue
-  = WorkQueue
-      { _wkqueueActive          :: !WorkInxSet                  -- ^ active queue, work will be taken off from this one
-      , _wkqueueRedo            :: !WorkInxSet                  -- ^ redo queue, holding work which could not immediately be reduced, but later on might be
-      , _wkqueueDidSomething    :: !Bool                        -- ^ flag indicating some work was done; if False and active queue is empty we stop solving
-      }
-  deriving (Typeable)
-
-emptyWorkQueue :: WorkQueue
-emptyWorkQueue = WorkQueue IntSet.empty IntSet.empty True
-
--------------------------------------------------------------------------------------------
---- A matched combi of chr and work
--------------------------------------------------------------------------------------------
-
--- | Already matched combi of chr and work
-data MatchedCombi' c w =
-  MatchedCombi
-    { mcCHR      :: !c              -- ^ the CHR
-    , mcWork     :: ![w]            -- ^ the work matched for this CHR
-    }
-  deriving (Eq, Ord)
-
-instance Show (MatchedCombi' c w) where
-  show _ = "MatchedCombi"
-
-instance (PP c, PP w) => PP (MatchedCombi' c w) where
-  pp (MatchedCombi c ws) = ppParensCommas [pp c, ppBracketsCommas ws]
-
-type MatchedCombi = MatchedCombi' CHRInx WorkInx
-
--------------------------------------------------------------------------------------------
---- Solver reduction step
--------------------------------------------------------------------------------------------
-
--- | Description of 1 chr reduction step taken by the solver
-data SolverReductionStep' c w
-  = SolverReductionStep
-      { slvredMatchedCombi        :: !(MatchedCombi' c w)
-      , slvredChosenBodyAltInx    :: !Int
-      , slvredNewWork             :: !(Map.Map ConstraintSolvesVia [w])
-      }
-  | SolverReductionDBG PP_Doc
-
-type SolverReductionStep = SolverReductionStep' CHRInx WorkInx
-
-instance Show (SolverReductionStep' c w) where
-  show _ = "SolverReductionStep"
-
-instance {-# OVERLAPPABLE #-} (PP c, PP w) => PP (SolverReductionStep' c w) where
-  pp (SolverReductionStep (MatchedCombi ci ws) a wns) = "STEP" >#< ci >|< "." >|< a >-< indent 2 ("+" >#< ppBracketsCommas ws >-< "-> (new)" >#< (ppAssocL $ Map.toList $ Map.map ppBracketsCommas wns)) -- (ppBracketsCommas wns >-< ppBracketsCommas wnbs)
-  pp (SolverReductionDBG p) = "DBG" >#< p
-
-instance (PP w) => PP (SolverReductionStep' Int w) where
-  pp (SolverReductionStep (MatchedCombi ci ws) a wns) = ci >|< "." >|< a >#< "+" >#< ppBracketsCommas ws >#< "-> (new)" >#< (ppAssocL $ Map.toList $ Map.map ppBracketsCommas wns) -- (ppBracketsCommas wns >-< ppBracketsCommas wnbs)
-  pp (SolverReductionDBG p) = "DBG" >#< p
-
--------------------------------------------------------------------------------------------
---- Waiting (for var resolution) work
--------------------------------------------------------------------------------------------
-
--- | Admin for waiting work
-data WaitForVar s
-  = WaitForVar
-      { _waitForVarVars      :: CHRWaitForVarSet s
-      , _waitForVarWorkInx   :: WorkInx
-      }
-  deriving (Typeable)
-
--- | Index into collection of 'WaitForVar'
-type WaitInx = Int
-
--------------------------------------------------------------------------------------------
---- The CHR monad, state, etc. Used to interact with store and solver
--------------------------------------------------------------------------------------------
-
--- | Global state
-data CHRGlobState cnstr guard bprio prio subst env m
-  = CHRGlobState
-      { _chrgstStore                 :: !(CHRStore cnstr guard bprio prio)                     -- ^ Actual database of rules, to be searched
-      , _chrgstNextFreeRuleInx       :: !CHRInx                                          -- ^ Next free rule identification, used by solving to identify whether a rule has been used for a constraint.
-                                                                                         --   The numbering is applied to constraints inside a rule which can be matched.
-      , _chrgstWorkStore             :: !(WorkStore cnstr)                               -- ^ Actual database of solvable constraints
-      , _chrgstNextFreeWorkInx       :: !WorkTime                                        -- ^ Next free work/constraint identification, used by solving to identify whether a rule has been used for a constraint.
-      , _chrgstScheduleQueue         :: !(Que.MinPQueue (CHRPrioEvaluatableVal bprio) (CHRMonoBacktrackPrioT cnstr guard bprio prio subst env m (SolverResult subst)))
-      , _chrgstTrace                 :: SolveTrace' cnstr (StoredCHR cnstr guard bprio prio) subst
-      , _chrgstStatNrSolveSteps      :: !Int
-      }
-  deriving (Typeable)
-
-emptyCHRGlobState :: CHRGlobState c g b p s e m
-emptyCHRGlobState = CHRGlobState emptyCHRStore 0 emptyWorkStore initWorkTime Que.empty emptySolveTrace 0
-
--- | Backtrackable state
-data CHRBackState cnstr bprio subst env
-  = CHRBackState
-      { _chrbstBacktrackPrio         :: !(CHRPrioEvaluatableVal bprio)                          -- ^ the current backtrack prio the solver runs on
-      
-      , _chrbstRuleWorkQueue         :: !WorkQueue                                              -- ^ work queue for rule matching
-      , _chrbstSolveQueue            :: !WorkQueue                                              -- ^ solve queue, constraints which are not solved by rule matching but with some domain specific solver, yielding variable subst constributing to backtrackable bindings
-      , _chrbstResidualQueue         :: [WorkInx]                                               -- ^ residual queue, constraints which are residual, no need to solve, etc
-      
-      , _chrbstMatchedCombis         :: !(Set.Set MatchedCombi)                                 -- ^ all combis of chr + work which were reduced, to prevent this from happening a second time (when propagating)
-      
-      , _chrbstFreshVar              :: !Int                                                    -- ^ for fresh var
-      , _chrbstSolveSubst            :: !subst                                                  -- ^ subst for variable bindings found during solving, not for the ones binding rule metavars during matching but for the user ones (in to be solved constraints)
-      , _chrbstWaitForVar            :: !(Map.Map (VarLookupKey subst) [WaitForVar subst])       -- ^ work waiting for a var to be bound
-      
-      , _chrbstReductionSteps        :: [SolverReductionStep]                                   -- ^ trace of reduction steps taken (excluding solve steps)
-      }
-  deriving (Typeable)
-
-emptyCHRBackState :: (CHREmptySubstitution s, Bounded (CHRPrioEvaluatableVal bp)) => CHRBackState c bp s e
-emptyCHRBackState = CHRBackState minBound emptyWorkQueue emptyWorkQueue [] Set.empty 0 chrEmptySubst Map.empty []
-
--- | Monad for CHR, taking from 'LogicStateT' the state and backtracking behavior
-type CHRMonoBacktrackPrioT cnstr guard bprio prio subst env m
-  = LogicStateT (CHRGlobState cnstr guard bprio prio subst env m) (CHRBackState cnstr bprio subst env) m
-
--- | All required behavior, as class alias
-class ( IsCHRSolvable env cnstr guard bprio prio subst
-      , Monad m
-      -- , Ord (TTKey cnstr)
-      -- , Ord prio
-      -- , Ord (VarLookupKey subst)
-      , VarLookup subst -- (VarLookupKey subst) (VarLookupVal subst)
-      -- , TTKeyable cnstr
-      -- , MonadIO m -- for debugging
-      , Fresh Int (ExtrValVarKey (VarLookupVal subst))
-      -- , VarLookupKey subst ~ ExtrValVarKey cnstr
-      , ExtrValVarKey (VarLookupVal subst) ~ VarLookupKey subst
-      , VarTerm (VarLookupVal subst)
-      ) => MonoBacktrackPrio cnstr guard bprio prio subst env m
-
--------------------------------------------------------------------------------------------
---- Solver result
--------------------------------------------------------------------------------------------
-
--- | Solver solution
-data SolverResult subst =
-  SolverResult
-    { slvresSubst                 :: subst                            -- ^ global found variable bindings
-    , slvresResidualCnstr         :: [WorkInx]                        -- ^ constraints which are residual, no need to solve, etc, leftover when ready, taken from backtrack state
-    , slvresWorkCnstr             :: [WorkInx]                        -- ^ constraints which are still unsolved, taken from backtrack state
-    , slvresWaitVarCnstr          :: [WorkInx]                        -- ^ constraints which are still unsolved, waiting for variable resolution
-    , slvresReductionSteps        :: [SolverReductionStep]            -- ^ how did we get to the result (taken from the backtrack state when a result is given back)
-    }
-
--------------------------------------------------------------------------------------------
---- Solver: required instances
--------------------------------------------------------------------------------------------
-
--- | (Class alias) API for solving requirements
-class ( IsCHRConstraint env c s
-      , IsCHRGuard env g s
-      , IsCHRBacktrackPrio env bp s
-      , IsCHRPrio env p s
-      , TrTrKey c ~ TTKey c
-      , PP (VarLookupKey s)
-      ) => IsCHRSolvable env c g bp p s
-
--------------------------------------------------------------------------------------------
---- Lens construction
--------------------------------------------------------------------------------------------
-
-mkLabel ''WaitForVar
-mkLabel ''StoredCHR
-mkLabel ''CHRStore
-mkLabel ''WorkStore
-mkLabel ''WorkQueue
-mkLabel ''CHRGlobState
-mkLabel ''CHRBackState
-
--------------------------------------------------------------------------------------------
---- Misc utils
--------------------------------------------------------------------------------------------
-
-getSolveTrace :: (PP c, PP g, PP bp, MonoBacktrackPrio c g bp p s e m) => CHRMonoBacktrackPrioT c g bp p s e m PP_Doc
-getSolveTrace = fmap (ppSolveTrace . reverse) $ getl $ fstl ^* chrgstTrace
-
--------------------------------------------------------------------------------------------
---- CHR store, API for adding rules
--------------------------------------------------------------------------------------------
-
-{-
--- | Combine lists of stored CHRs by concat, adapting their identification nr to be unique
-cmbStoredCHRs :: [StoredCHR c g bp p] -> [StoredCHR c g bp p] -> [StoredCHR c g bp p]
-cmbStoredCHRs s1 s2
-  = map (\s@(StoredCHR {storedIdent=(k,nr)}) -> s {storedIdent = (k,nr+l)}) s1 ++ s2
-  where l = length s2
--}
-
-instance Show (StoredCHR c g bp p) where
-  show _ = "StoredCHR"
-
-ppStoredCHR :: (PP (TTKey c), PP c, PP g, PP bp, PP p) => StoredCHR c g bp p -> PP_Doc
-ppStoredCHR c@(StoredCHR {})
-  = ppParensCommas (_storedHeadKeys c)
-    >-< _storedChrRule c
-    >-< indent 2
-          (ppParensCommas
-            [ pp $ _storedChrInx c
-            -- , pp $ storedSimpSz c
-            -- , "keys" >#< (ppBracketsCommas $ map (maybe (pp "?") ppTreeTrieKey) $ storedKeys c)
-            -- , "ident" >#< ppParensCommas [ppTreeTrieKey idKey,pp idSeqNr]
-            ])
-
-instance (PP (TTKey c), PP c, PP g, PP bp, PP p) => PP (StoredCHR c g bp p) where
-  pp = ppStoredCHR
-
-{-
--- | Convert from list to store
-chrStoreFromElems :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => [Rule c g bp p] -> CHRStore c g b p
-chrStoreFromElems chrs
-  = mkCHRStore
-    $ chrTrieFromListByKeyWith cmbStoredCHRs
-        [ (k,[StoredCHR chr i ks' (concat ks,0)])
-        | chr <- chrs
-        , let cs = ruleHead chr
-              simpSz = ruleSimpSz chr
-              ks = map chrToKey cs
-        , (c,k,i) <- zip3 cs ks [0..]
-        , let (ks1,(_:ks2)) = splitAt i ks
-              ks' = map Just ks1 ++ [Nothing] ++ map Just ks2
-        ]
--}
-
--- | Add a rule as a CHR
-addRule :: MonoBacktrackPrio c g bp p s e m => Rule c g bp p -> CHRMonoBacktrackPrioT c g bp p s e m ()
-addRule chr = do
-    i <- modifyAndGet (fstl ^* chrgstNextFreeRuleInx) $ \i -> (i, i + 1)
-    let ks = map chrToKey $ ruleHead chr
-    fstl ^* chrgstStore ^* chrstoreTable =$: IntMap.insert i (StoredCHR ks chr i)
-    fstl ^* chrgstStore ^* chrstoreTrie =$: \t ->
-      foldr (TreeTrie.unionWith (++)) t [ TreeTrie.singleton k [CHRConstraintInx i j] | (k,c,j) <- zip3 ks (ruleHead chr) [0..] ]
-    return ()
-
--- | Add work to the rule work queue
-addToWorkQueue :: MonoBacktrackPrio c g bp p s e m => WorkInx -> CHRMonoBacktrackPrioT c g bp p s e m ()
-addToWorkQueue i = do
-    sndl ^* chrbstRuleWorkQueue ^* wkqueueActive =$: (IntSet.insert i)
-    sndl ^* chrbstRuleWorkQueue ^* wkqueueDidSomething =: True
-{-# INLINE addToWorkQueue #-}
-
--- | Add redo work to the rule work queue
-addRedoToWorkQueue :: MonoBacktrackPrio c g bp p s e m => WorkInx -> CHRMonoBacktrackPrioT c g bp p s e m ()
-addRedoToWorkQueue i = do
-    sndl ^* chrbstRuleWorkQueue ^* wkqueueRedo =$: (IntSet.insert i)
-{-# INLINE addRedoToWorkQueue #-}
-
--- | Add work to the wait for var queue
-addWorkToWaitForVarQueue :: (MonoBacktrackPrio c g bp p s e m, Ord (VarLookupKey s)) => CHRWaitForVarSet s -> WorkInx -> CHRMonoBacktrackPrioT c g bp p s e m ()
-addWorkToWaitForVarQueue wfvs wi = do
-    let w = WaitForVar wfvs wi
-    sndl ^* chrbstWaitForVar =$: Map.unionWith (++) (Map.fromList [(v,[w]) | v <- Set.toList wfvs])
-
--- | For (new) found subst split off work waiting for it
-splitOffResolvedWaitForVarWork :: (MonoBacktrackPrio c g bp p s e m, Ord (VarLookupKey s)) => CHRWaitForVarSet s -> CHRMonoBacktrackPrioT c g bp p s e m [WorkInx]
-splitOffResolvedWaitForVarWork vars = do
-    -- wait admin
-    wm <- getl $ sndl ^* chrbstWaitForVar
-    let -- split off the part which can be released
-        (wmRelease,wmRemain) = Map.partitionWithKey (\v _ -> Set.member v vars) wm
-        wfvs = concat $ Map.elems wmRelease
-        -- get all influenced vars and released work
-        (wvars, winxs) = (\(vss,wis) -> (Set.unions vss, IntSet.fromList wis)) $ unzip [ (vs,wi) | (WaitForVar {_waitForVarVars=vs, _waitForVarWorkInx=wi}) <- wfvs ]
-    -- remove released work from remaining admin for influenced vars
-    sndl ^* chrbstWaitForVar =:
-      foldr (Map.alter $ maybe Nothing $ \wfvs -> case filter (\i -> _waitForVarWorkInx i `IntSet.notMember` winxs) wfvs of
-                [] -> Nothing
-                wfvs' -> Just wfvs'
-            )
-            wmRemain
-            (Set.toList wvars)
-
-    -- released work
-    return $ IntSet.toList winxs
-
-
--- | Add work to the solve queue
-addWorkToSolveQueue :: MonoBacktrackPrio c g bp p s e m => WorkInx -> CHRMonoBacktrackPrioT c g bp p s e m ()
-addWorkToSolveQueue i = do
-    sndl ^* chrbstSolveQueue ^* wkqueueActive =$: (IntSet.insert i)
-
--- | Split off work from the solve work queue, possible none left
-splitWorkFromSolveQueue :: MonoBacktrackPrio c g bp p s e m => CHRMonoBacktrackPrioT c g bp p s e m (Maybe (WorkInx))
-splitWorkFromSolveQueue = do
-    wq <- getl $ sndl ^* chrbstSolveQueue ^* wkqueueActive
-    case IntSet.minView wq of
-      Nothing ->
-          return Nothing
-      Just (workInx, wq') -> do
-          sndl ^* chrbstSolveQueue ^* wkqueueActive =: wq'
-          return $ Just (workInx)
-
--- | Remove work from the work queue
-deleteFromWorkQueue :: MonoBacktrackPrio c g bp p s e m => WorkInxSet -> CHRMonoBacktrackPrioT c g bp p s e m ()
-deleteFromWorkQueue is = do
-    -- sndl ^* chrbstRuleWorkQueue ^* wkqueueActive =$: (\s -> foldr (IntSet.delete) s is)
-    sndl ^* chrbstRuleWorkQueue ^* wkqueueActive =$: flip IntSet.difference is
-    sndl ^* chrbstRuleWorkQueue ^* wkqueueRedo =$: flip IntSet.difference is
-
--- | Extract the active work in the queue
-waitingInWorkQueue :: MonoBacktrackPrio c g bp p s e m => CHRMonoBacktrackPrioT c g bp p s e m WorkInxSet
-waitingInWorkQueue = do
-    a <- getl $ sndl ^* chrbstRuleWorkQueue ^* wkqueueActive
-    r <- getl $ sndl ^* chrbstRuleWorkQueue ^* wkqueueRedo
-    return $ IntSet.union a r
-
--- | Split off work from the work queue, possible none left
-splitFromWorkQueue :: MonoBacktrackPrio c g bp p s e m => CHRMonoBacktrackPrioT c g bp p s e m (Maybe WorkInx)
-splitFromWorkQueue = do
-    wq <- getl $ sndl ^* chrbstRuleWorkQueue ^* wkqueueActive
-    case IntSet.minView wq of
-      -- If no more work, ready if nothing was done anymore
-      Nothing -> do
-          did <- modifyAndGet (sndl ^* chrbstRuleWorkQueue ^* wkqueueDidSomething) $ \d -> (d, False)
-          if did -- && not (IntSet.null wr)
-            then do
-              wr  <- modifyAndGet (sndl ^* chrbstRuleWorkQueue ^* wkqueueRedo) $ \r -> (r, IntSet.empty)
-              sndl ^* chrbstRuleWorkQueue ^* wkqueueActive =: wr
-              splitFromWorkQueue
-            else
-              return Nothing
-      
-      -- There is work in the queue
-      Just (workInx, wq') -> do
-          sndl ^* chrbstRuleWorkQueue ^* wkqueueActive =: wq'
-          return $ Just workInx
-
--- | Add a constraint to be solved or residualised
-addConstraintAsWork :: MonoBacktrackPrio c g bp p s e m => c -> CHRMonoBacktrackPrioT c g bp p s e m (ConstraintSolvesVia, WorkInx)
-addConstraintAsWork c = do
-    let via = cnstrSolvesVia c
-        addw i w = do
-          fstl ^* chrgstWorkStore ^* wkstoreTable =$: IntMap.insert i w
-          return (via,i)
-    i <- fresh
-    w <- case via of
-        -- a plain rule is added to the work store
-        ConstraintSolvesVia_Rule -> do
-            fstl ^* chrgstWorkStore ^* wkstoreTrie =$: TreeTrie.insertByKeyWith (++) k [i]
-            addToWorkQueue i
-            return $ Work k c i
-          where k = chrToKey c -- chrToWorkKey c
-        -- work for the solver is added to its own queue
-        ConstraintSolvesVia_Solve -> do
-            addWorkToSolveQueue i
-            return $ Work_Solve c
-        -- residue is just remembered
-        ConstraintSolvesVia_Residual -> do
-            sndl ^* chrbstResidualQueue =$: (i :)
-            return $ Work_Residue c
-        -- fail right away if this constraint is a fail constraint
-        ConstraintSolvesVia_Fail -> do
-            addWorkToSolveQueue i
-            return Work_Fail
-    addw i w
-{-
-        -- succeed right away if this constraint is a succes constraint
-        -- TBD, different return value of slvSucces...
-        ConstraintSolvesVia_Succeed -> do
-            slvSucces
--}
-  where
-    fresh = modifyAndGet (fstl ^* chrgstNextFreeWorkInx) $ \i -> (i, i + 1)
-{-
-
-chrStoreSingletonElem :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => Rule c g bp p -> CHRStore c g b p
-chrStoreSingletonElem x = chrStoreFromElems [x]
-
-chrStoreUnion :: (Ord (TTKey c)) => CHRStore c g b p -> CHRStore c g b p -> CHRStore c g b p
-chrStoreUnion cs1 cs2 = mkCHRStore $ chrTrieUnionWith cmbStoredCHRs (chrstoreTrie cs1) (chrstoreTrie cs2)
-{-# INLINE chrStoreUnion #-}
-
-chrStoreUnions :: (Ord (TTKey c)) => [CHRStore c g b p] -> CHRStore c g b p
-chrStoreUnions []  = emptyCHRStore
-chrStoreUnions [s] = s
-chrStoreUnions ss  = foldr1 chrStoreUnion ss
-{-# INLINE chrStoreUnions #-}
-
-chrStoreToList :: (Ord (TTKey c)) => CHRStore c g b p -> [(CHRKey c,[Rule c g bp p])]
-chrStoreToList cs
-  = [ (k,chrs)
-    | (k,e) <- chrTrieToListByKey $ chrstoreTrie cs
-    , let chrs = [chr | (StoredCHR {storedChrRule = chr, storedChrInx = 0}) <- e]
-    , not $ Prelude.null chrs
-    ]
-
-chrStoreElems :: (Ord (TTKey c)) => CHRStore c g b p -> [Rule c g bp p]
-chrStoreElems = concatMap snd . chrStoreToList
-
-ppCHRStore :: (PP c, PP g, PP p, Ord (TTKey c), PP (TTKey c)) => CHRStore c g b p -> PP_Doc
-ppCHRStore = ppCurlysCommasBlock . map (\(k,v) -> ppTreeTrieKey k >-< indent 2 (":" >#< ppBracketsCommasBlock v)) . chrStoreToList
-
-ppCHRStore' :: (PP c, PP g, PP p, Ord (TTKey c), PP (TTKey c)) => CHRStore c g b p -> PP_Doc
-ppCHRStore' = ppCurlysCommasBlock . map (\(k,v) -> ppTreeTrieKey k >-< indent 2 (":" >#< ppBracketsCommasBlock v)) . chrTrieToListByKey . chrstoreTrie
-
--}
-
--------------------------------------------------------------------------------------------
---- Solver combinators
--------------------------------------------------------------------------------------------
-
--- | Succesful return, solution is found
-slvSucces :: MonoBacktrackPrio c g bp p s e m => [WorkInx] -> CHRMonoBacktrackPrioT c g bp p s e m (SolverResult s)
-slvSucces leftoverWork = do
-    bst <- getl $ sndl
-    let ret = return $ SolverResult
-          { slvresSubst = bst ^. chrbstSolveSubst
-          , slvresResidualCnstr = reverse $ bst ^. chrbstResidualQueue
-          , slvresWorkCnstr = leftoverWork
-          , slvresWaitVarCnstr = [ wfv ^. waitForVarWorkInx | wfvs <- Map.elems $ bst ^. chrbstWaitForVar, wfv <- wfvs ]
-          , slvresReductionSteps = reverse $ bst ^. chrbstReductionSteps
-          }
-    -- when ready, just return and backtrack into the scheduler
-    ret `mplus` slvScheduleRun
-
--- | Failure return, no solution is found
-slvFail :: MonoBacktrackPrio c g bp p s e m => CHRMonoBacktrackPrioT c g bp p s e m (SolverResult s)
-slvFail = do
-    -- failing just terminates this slv, scheduling to another, if any
-    slvScheduleRun
-{-# INLINE slvFail #-}
-
--- | Schedule a solver with the current backtrack prio, assuming this is the same as 'slv' has administered itself in its backtracking state
-slvSchedule :: MonoBacktrackPrio c g bp p s e m => CHRPrioEvaluatableVal bp -> CHRMonoBacktrackPrioT c g bp p s e m (SolverResult s) -> CHRMonoBacktrackPrioT c g bp p s e m ()
-slvSchedule bprio slv = do
-    -- bprio <- getl $ sndl ^* chrbstBacktrackPrio
-    fstl ^* chrgstScheduleQueue =$: Que.insert bprio slv
-{-# INLINE slvSchedule #-}
-
--- | Schedule a solver with the current backtrack prio, assuming this is the same as 'slv' has administered itself in its backtracking state
-slvSchedule' :: MonoBacktrackPrio c g bp p s e m => CHRMonoBacktrackPrioT c g bp p s e m (SolverResult s) -> CHRMonoBacktrackPrioT c g bp p s e m ()
-slvSchedule' slv = do
-    bprio <- getl $ sndl ^* chrbstBacktrackPrio
-    slvSchedule bprio slv
-{-# INLINE slvSchedule' #-}
-
--- | Rechedule a solver, switching context/prio
-slvReschedule :: MonoBacktrackPrio c g bp p s e m => CHRMonoBacktrackPrioT c g bp p s e m (SolverResult s) -> CHRMonoBacktrackPrioT c g bp p s e m (SolverResult s)
-slvReschedule slv = do
-    slvSchedule' slv
-    slvScheduleRun
-{-# INLINE slvReschedule #-}
-
--- | Retrieve solver with the highest prio from the schedule queue
-slvSplitFromSchedule :: MonoBacktrackPrio c g bp p s e m => CHRMonoBacktrackPrioT c g bp p s e m (Maybe (CHRPrioEvaluatableVal bp, CHRMonoBacktrackPrioT c g bp p s e m (SolverResult s)))
-slvSplitFromSchedule = modifyAndGet (fstl ^* chrgstScheduleQueue) $ \q -> (Que.getMin q, Que.deleteMin q)
-{-# INLINE slvSplitFromSchedule #-}
-
--- | Run from the schedule que, fail if nothing left to be done
-slvScheduleRun :: MonoBacktrackPrio c g bp p s e m => CHRMonoBacktrackPrioT c g bp p s e m (SolverResult s)
-slvScheduleRun = slvSplitFromSchedule >>= maybe mzero snd
-{-# INLINE slvScheduleRun #-}
-
--------------------------------------------------------------------------------------------
---- Solver utils
--------------------------------------------------------------------------------------------
-
-lkupWork :: MonoBacktrackPrio c g bp p s e m => WorkInx -> CHRMonoBacktrackPrioT c g bp p s e m (Work c)
-lkupWork i = fmap (IntMap.findWithDefault (panic "MBP.wkstoreTable.lookup") i) $ getl $ fstl ^* chrgstWorkStore ^* wkstoreTable
-
-lkupChr :: MonoBacktrackPrio c g bp p s e m => CHRInx -> CHRMonoBacktrackPrioT c g bp p s e m (StoredCHR c g bp p)
-lkupChr  i = fmap (IntMap.findWithDefault (panic "MBP.chrSolve.chrstoreTable.lookup") i) $ getl $ fstl ^* chrgstStore ^* chrstoreTable
-
--- | Convert
-cvtSolverReductionStep :: MonoBacktrackPrio c g bp p s e m => SolverReductionStep' CHRInx WorkInx -> CHRMonoBacktrackPrioT c g bp p s e m (SolverReductionStep' (StoredCHR c g bp p) (Work c))
-cvtSolverReductionStep (SolverReductionStep mc ai nw) = do
-    mc  <- cvtMC mc
-    nw  <- fmap Map.fromList $ forM (Map.toList nw) $ \(via,i) -> do
-             i <- forM i lkupWork
-             return (via, i)
-    return $ SolverReductionStep mc ai nw
-  where
-    cvtMC (MatchedCombi {mcCHR = c, mcWork = ws}) = do
-      c'  <- lkupChr c
-      ws' <- forM ws lkupWork
-      return $ MatchedCombi c' ws'
-cvtSolverReductionStep (SolverReductionDBG pp) = return (SolverReductionDBG pp)
-
--- | PP result
-ppSolverResult
-  :: ( MonoBacktrackPrio c g bp p s e m
-     , VarUpdatable s s
-     , PP s
-     ) => Verbosity
-       -> SolverResult s
-       -> CHRMonoBacktrackPrioT c g bp p s e m PP_Doc
-ppSolverResult verbosity (SolverResult {slvresSubst = s, slvresResidualCnstr = ris, slvresWorkCnstr = wis, slvresWaitVarCnstr = wvis, slvresReductionSteps = steps}) = do
-    rs  <- forM ris  $ \i -> lkupWork i >>= return . pp . workCnstr
-    ws  <- forM wis  $ \i -> lkupWork i >>= return . pp . workCnstr
-    wvs <- forM wvis $ \i -> lkupWork i >>= return . pp . workCnstr
-    ss  <- if verbosity >= Verbosity_ALot
-      then forM steps $ \step -> cvtSolverReductionStep step >>= (return . pp)
-      else return [pp $ "Only included with enough verbosity turned on"]
-    nrsteps <- getl $ fstl ^* chrgstStatNrSolveSteps
-    let pextra | verbosity >= Verbosity_Normal = 
-                      "Residue" >-< indent 2 (vlist rs)
-                  >-< "Wait"    >-< indent 2 (vlist wvs)
-                  >-< "Stats"   >-< indent 2 (ppAssocLV [ ("Count of overall solve steps", pp nrsteps) ])
-                  >-< "Steps"   >-< indent 2 (vlist ss)
-               | otherwise = Pretty.empty
-    return $ 
-          "Subst"   >-< indent 2 (s `varUpd` s)
-      >-< "Work"    >-< indent 2 (vlist ws)
-      >-< pextra
-
--------------------------------------------------------------------------------------------
---- Solver: running it
--------------------------------------------------------------------------------------------
-
--- | Run and observe results
-runCHRMonoBacktrackPrioT
-  :: MonoBacktrackPrio cnstr guard bprio prio subst env m
-     => CHRGlobState cnstr guard bprio prio subst env m
-     -> CHRBackState cnstr bprio subst env
-     -- -> CHRPrioEvaluatableVal bprio
-     -> CHRMonoBacktrackPrioT cnstr guard bprio prio subst env m (SolverResult subst)
-     -> m [SolverResult subst]
-runCHRMonoBacktrackPrioT gs bs {- bp -} m = observeAllT (gs, bs {- _chrbstBacktrackPrio=bp -}) m
-
--------------------------------------------------------------------------------------------
---- Solver: Intermediate structures
--------------------------------------------------------------------------------------------
-
--- | Intermediate Solver structure
-data FoundChr c g bp p
-  = FoundChr
-      { foundChrInx             :: !CHRInx
-      , foundChrChr             :: !(StoredCHR c g bp p)
-      , foundChrCnstr           :: ![WorkInx]
-      }
-
--- | Intermediate Solver structure
-data FoundWorkInx c g bp p
-  = FoundWorkInx
-      { foundWorkInxInx         :: !CHRConstraintInx
-      , foundWorkInxChr         :: !(StoredCHR c g bp p)
-      , foundWorkInxWorkInxs    :: ![[WorkInx]]
-      }
-
--- | Intermediate Solver structure: sorting key for matches
-data FoundMatchSortKey bp p s
-  = FoundMatchSortKey
-      { {- foundMatchSortKeyBacktrackPrio  :: !(CHRPrioEvaluatableVal bp)
-      , -} foundMatchSortKeyPrio           :: !(Maybe (s,p))
-      , foundMatchSortKeyWaitSize       :: !Int
-      , foundMatchSortKeyTextOrder      :: !CHRInx
-      }
-
-instance Show (FoundMatchSortKey bp p s) where
-  show _ = "FoundMatchSortKey"
-
-instance (PP p, PP s) => PP (FoundMatchSortKey bp p s) where
-  pp (FoundMatchSortKey {foundMatchSortKeyPrio=p, foundMatchSortKeyWaitSize=w, foundMatchSortKeyTextOrder=o}) = ppParensCommas [pp p, pp w, pp o]
-
-compareFoundMatchSortKey :: {- (Ord (CHRPrioEvaluatableVal bp)) => -} ((s,p) -> (s,p) -> Ordering) -> FoundMatchSortKey bp p s -> FoundMatchSortKey bp p s -> Ordering
-compareFoundMatchSortKey cmp_rp (FoundMatchSortKey {- bp1 -} rp1 ws1 to1) (FoundMatchSortKey {- bp2 -} rp2 ws2 to2) =
-    {- orderingLexic (bp1 `compare` bp2) $ -} orderingLexic (rp1 `cmp_mbrp` rp2) $ orderingLexic (ws1 `compare` ws2) $ to1 `compare` to2
-  where
-    cmp_mbrp (Just rp1) (Just rp2) = cmp_rp rp1 rp2
-    cmp_mbrp (Just _  ) _          = GT
-    cmp_mbrp _          (Just _  ) = LT
-    cmp_mbrp _          _          = EQ
-
--- | Intermediate Solver structure: body alternative, together with index position
-data FoundBodyAlt c bp
-  = FoundBodyAlt
-      { foundBodyAltInx             :: !Int
-      , foundBodyAltBacktrackPrio   :: !(CHRPrioEvaluatableVal bp)
-      , foundBodyAltAlt             :: !(RuleBodyAlt c bp)
-      }
-
-instance Show (FoundBodyAlt c bp) where
-  show _ = "FoundBodyAlt"
-
-instance (PP c, PP bp, PP (CHRPrioEvaluatableVal bp)) => PP (FoundBodyAlt c bp) where
-  pp (FoundBodyAlt {foundBodyAltInx=i, foundBodyAltBacktrackPrio=bp, foundBodyAltAlt=a}) = i >|< ":" >|< ppParens bp >#< a
-
--- | Intermediate Solver structure: all matched combis with their body alternatives + backtrack priorities
-data FoundSlvMatch c g bp p s
-  = FoundSlvMatch
-      { foundSlvMatchSubst          :: !s                                   -- ^ the subst of rule meta vars making this a rule + work combi match
-      , foundSlvMatchFreeVars       :: !(CHRWaitForVarSet s)                -- ^ free meta vars of head
-      , foundSlvMatchWaitForVars    :: !(CHRWaitForVarSet s)                -- ^ for the work we try to solve the (global) vars on which we have to wait to continue
-      , foundSlvMatchSortKey        :: !(FoundMatchSortKey bp p s)          -- ^ key to sort found matches
-      , foundSlvMatchBodyAlts       :: ![FoundBodyAlt c bp]                 -- ^ the body alternatives of the rule which matches
-      }
-
-instance Show (FoundSlvMatch c g bp p s) where
-  show _ = "FoundSlvMatch"
-
-instance (PP s, PP p, PP c, PP bp, PP (VarLookupKey s), PP (CHRPrioEvaluatableVal bp)) => PP (FoundSlvMatch c g bp p s) where
-  pp (FoundSlvMatch {foundSlvMatchSubst=s, foundSlvMatchWaitForVars=ws, foundSlvMatchBodyAlts=as}) = ws >#< s >-< vlist as
-
--- | Intermediate Solver structure: all matched combis with their backtrack prioritized body alternatives
-data FoundWorkMatch c g bp p s
-  = FoundWorkMatch
-      { foundWorkMatchInx       :: !CHRConstraintInx
-      , foundWorkMatchChr       :: !(StoredCHR c g bp p)
-      , foundWorkMatchWorkInx   :: ![WorkInx]
-      , foundWorkMatchSlvMatch  :: !(Maybe (FoundSlvMatch c g bp p s))
-      }
-
-instance Show (FoundWorkMatch c g bp p s) where
-  show _ = "FoundWorkMatch"
-
-instance (PP c, PP bp, PP p, PP s, PP (VarLookupKey s), PP (CHRPrioEvaluatableVal bp)) => PP (FoundWorkMatch c g bp p s) where
-  pp (FoundWorkMatch {foundWorkMatchSlvMatch=sm}) = pp sm
-
--- | Intermediate Solver structure: all matched combis with their backtrack prioritized body alternatives
-data FoundWorkSortedMatch c g bp p s
-  = FoundWorkSortedMatch
-      { foundWorkSortedMatchInx             :: !CHRConstraintInx
-      , foundWorkSortedMatchChr             :: !(StoredCHR c g bp p)
-      , foundWorkSortedMatchBodyAlts        :: ![FoundBodyAlt c bp]
-      , foundWorkSortedMatchWorkInx         :: ![WorkInx]
-      , foundWorkSortedMatchSubst           :: !s
-      , foundWorkSortedMatchFreeVars        :: !(CHRWaitForVarSet s)
-      , foundWorkSortedMatchWaitForVars     :: !(CHRWaitForVarSet s)
-      }
-
-instance Show (FoundWorkSortedMatch c g bp p s) where
-  show _ = "FoundWorkSortedMatch"
-
-instance (PP c, PP bp, PP p, PP s, PP g, PP (TTKey c), PP (VarLookupKey s), PP (CHRPrioEvaluatableVal bp)) => PP (FoundWorkSortedMatch c g bp p s) where
-  pp (FoundWorkSortedMatch {foundWorkSortedMatchBodyAlts=as, foundWorkSortedMatchWorkInx=wis, foundWorkSortedMatchSubst=s, foundWorkSortedMatchWaitForVars=wvs})
-    = wis >-< s >#< ppParens wvs >-< vlist as
-
--------------------------------------------------------------------------------------------
---- Solver options
--------------------------------------------------------------------------------------------
-
--- | Solve specific options
-data CHRSolveOpts
-  = CHRSolveOpts
-      { chrslvOptSucceedOnLeftoverWork  :: !Bool        -- ^ left over unresolvable (non residue) work is also a successful result
-      , chrslvOptSucceedOnFailedSolve   :: !Bool        -- ^ failed solve is considered also a successful result, with the failed constraint as a residue
-      }
-
-defaultCHRSolveOpts :: CHRSolveOpts
-defaultCHRSolveOpts
-  = CHRSolveOpts
-      { chrslvOptSucceedOnLeftoverWork  = False
-      , chrslvOptSucceedOnFailedSolve   = False
-      }
-
--------------------------------------------------------------------------------------------
---- Solver
--------------------------------------------------------------------------------------------
-
--- | (Under dev) solve
-chrSolve
-  :: forall c g bp p s e m .
-     ( MonoBacktrackPrio c g bp p s e m
-     , PP s
-     ) => CHRSolveOpts
-       -> e
-       -> CHRMonoBacktrackPrioT c g bp p s e m (SolverResult s)
-chrSolve opts env = slv
-  where
-    -- solve
-    slv = do
-        fstl ^* chrgstStatNrSolveSteps =$: (+1)
-        mbSlvWk <- splitWorkFromSolveQueue
-        case mbSlvWk of
-          -- There is work in the solve work queue
-          Just (workInx) -> do
-              work <- lkupWork workInx
-              case work of
-                Work_Fail -> slvFail
-                _ -> do
-                  subst <- getl $ sndl ^* chrbstSolveSubst
-                  let mbSlv = chrmatcherRun (chrBuiltinSolveM env $ workCnstr work) emptyCHRMatchEnv subst
-                  
-                  -- debug info
-                  sndl ^* chrbstReductionSteps =$: (SolverReductionDBG
-                    (    "solve wk" >#< work
-                     >-< "match" >#< mbSlv
-                    ) :)
-
-                  case mbSlv of
-                    Just (s,_) -> do
-                          -- the newfound subst may reactivate waiting work
-                          splitOffResolvedWaitForVarWork (varlookupKeysSet s) >>= mapM_ addToWorkQueue
-                          sndl ^* chrbstSolveSubst =$: (s |+>)
-                          -- just continue with next work
-                          slv
-                    _ | chrslvOptSucceedOnFailedSolve opts -> do
-                          sndl ^* chrbstResidualQueue =$: (workInx :)
-                          -- just continue with next work
-                          slv
-                      | otherwise -> do
-                          slvFail
-
-
-          -- If no more solve work, continue with normal work
-          Nothing -> do
-              waitingWk <- waitingInWorkQueue
-              visitedChrWkCombis <- getl $ sndl ^* chrbstMatchedCombis
-              mbWk <- splitFromWorkQueue
-              case mbWk of
-                -- If no more work, ready or cannot proceed
-                Nothing -> do
-                    wr <- getl $ sndl ^* chrbstRuleWorkQueue ^* wkqueueRedo
-                    if chrslvOptSucceedOnLeftoverWork opts || IntSet.null wr
-                      then slvSucces $ IntSet.toList wr
-                      else slvFail
-      
-                -- There is work in the queue
-                Just workInx -> do
-                    -- lookup the work
-                    work <- lkupWork workInx
-          
-                    -- find all matching chrs for the work
-                    foundChrInxs <- slvLookup (workKey work) (chrgstStore ^* chrstoreTrie)
-                    -- remove duplicates, regroup
-                    let foundChrGroupedInxs = Map.unionsWith Set.union $ map (\(CHRConstraintInx i j) -> Map.singleton i (Set.singleton j)) foundChrInxs
-                    foundChrs <- forM (Map.toList foundChrGroupedInxs) $ \(chrInx,rlInxs) -> lkupChr chrInx >>= \chr -> return $ FoundChr chrInx chr $ Set.toList rlInxs
-
-                    -- found chrs for the work correspond to 1 single position in the head, find all combinations with work in the queue
-                    foundWorkInxs <- sequence
-                      [ fmap (FoundWorkInx (CHRConstraintInx ci i) c) $ slvCandidate waitingWk visitedChrWkCombis workInx c i
-                      | FoundChr ci c is <- foundChrs, i <- is
-                      ]
-          
-                    -- each found combi has to match
-                    foundWorkMatches <- fmap concat $
-                      forM foundWorkInxs $ \(FoundWorkInx ci c wis) -> do
-                        forM wis $ \wi -> do
-                          w <- forM wi lkupWork
-                          fmap (FoundWorkMatch ci c wi) $ slvMatch env c (map workCnstr w) (chrciAt ci)
-
-                    -- split off the work which has to wait for variable bindings (as indicated by matching)
-                    -- let () = partition () foundWorkMatches
-                    -- sort over priorities
-                    let foundWorkSortedMatches = sortByOn (compareFoundMatchSortKey $ chrPrioCompare env) fst
-                          [ (k, FoundWorkSortedMatch (foundWorkMatchInx fwm) (foundWorkMatchChr fwm) (foundSlvMatchBodyAlts sm)
-                                                     (foundWorkMatchWorkInx fwm) (foundSlvMatchSubst sm) (foundSlvMatchFreeVars sm) (foundSlvMatchWaitForVars sm))
-                          | fwm@(FoundWorkMatch {foundWorkMatchSlvMatch = Just sm@(FoundSlvMatch {foundSlvMatchSortKey=k})}) <- foundWorkMatches
-                          -- , (k,a) <- foundSlvMatchBodyAlts sm
-                          ]
-
-                    bprio <- getl $ sndl ^* chrbstBacktrackPrio
-                    subst <- getl $ sndl ^* chrbstSolveSubst
-                    dbgWaitInfo <- getl $ sndl ^* chrbstWaitForVar
-                    -- sque <- getl $ fstl ^* chrgstScheduleQueue
-                    -- debug info
-                    let dbg =      "bprio" >#< bprio
-                               >-< "wk" >#< (work >-< subst `varUpd` workCnstr work)
-                               >-< "que" >#< ppBracketsCommas (IntSet.toList waitingWk)
-                               >-< "subst" >#< subst
-                               >-< "wait" >#< ppAssocL (assocLMapElt (ppAssocL . map (\i -> (_waitForVarWorkInx i, ppCommas $ Set.toList $ _waitForVarVars i))) $ Map.toList dbgWaitInfo)
-                               >-< "visited" >#< ppBracketsCommas (Set.toList visitedChrWkCombis)
-                               >-< "chrs" >#< vlist [ ci >|< ppParensCommas is >|< ":" >#< c | FoundChr ci c is <- foundChrs ]
-                               >-< "works" >#< vlist [ ci >|< ":" >#< vlist (map ppBracketsCommas ws) | FoundWorkInx ci c ws <- foundWorkInxs ]
-                               >-< "matches" >#< vlist [ ci >|< ":" >#< ppBracketsCommas wi >#< ":" >#< mbm | FoundWorkMatch ci _ wi mbm <- foundWorkMatches ]
-                               -- >-< "prio'd" >#< (vlist $ zipWith (\g ms -> g >|< ":" >#< vlist [ ci >|< ":" >#< ppBracketsCommas wi >#< ":" >#< s | (ci,_,wi,s) <- ms ]) [0::Int ..] foundWorkMatchesFilteredPriod)
-                               -- >-< "prio'd" >#< ppAssocL (zip [0::Int ..] $ map ppAssocL foundWorkSortedMatches)
-                    sndl ^* chrbstReductionSteps =$: (SolverReductionDBG dbg :)
-
-                    -- pick the first and highest rule prio solution
-                    case foundWorkSortedMatches of
-                      ((_,fwsm@(FoundWorkSortedMatch {foundWorkSortedMatchWaitForVars = waitForVars})):_)
-                        | Set.null waitForVars -> do
-                            -- addRedoToWorkQueue workInx
-                            addToWorkQueue workInx
-                            slv1 bprio fwsm
-                        | otherwise -> do
-                            -- put on wait queue if there are unresolved variables
-                            addWorkToWaitForVarQueue waitForVars workInx
-                            -- continue without reschedule
-                            slv
-                      _ -> do
-                            addRedoToWorkQueue workInx
-                            slv
-{-
-                      _ | chrslvOptSucceedOnLeftoverWork opts -> do
-                            -- no chr applies for this work, so consider it to be residual
-                            sndl ^* chrbstLeftWorkQueue =$: (workInx :)
-                            -- continue without reschedule
-                            slv
-                        | otherwise -> do
-                            -- no chr applies for this work, can never be resolved, consider this a failure unless prevented by option
-                            slvFail
--}
-
-    -- solve one step further, allowing a backtrack point here
-    slv1 curbprio
-         (FoundWorkSortedMatch
-            { foundWorkSortedMatchInx = CHRConstraintInx {chrciInx = ci}
-            , foundWorkSortedMatchChr = chr@StoredCHR {_storedChrRule = Rule {ruleSimpSz = simpSz}}
-            , foundWorkSortedMatchBodyAlts = alts
-            , foundWorkSortedMatchWorkInx = workInxs
-            , foundWorkSortedMatchSubst = matchSubst
-            , foundWorkSortedMatchFreeVars = freeHeadVars
-            }) = do
-        -- remove the simplification part from the work queue
-        deleteFromWorkQueue $ IntSet.fromList $ take simpSz workInxs
-        -- depending on nr of alts continue slightly different
-        case alts of
-          -- just continue if no alts 
-          [] -> do
-            log Nothing
-            slv
-          -- just reschedule
-          [alt@(FoundBodyAlt {foundBodyAltBacktrackPrio=bprio})]
-            | curbprio == bprio -> do
-                log (Just alt)
-                nextwork bprio alt
-            | otherwise -> do
-                log (Just alt)
-                slvSchedule bprio $ nextwork bprio alt
-                slvScheduleRun
-          -- otherwise backtrack and schedule all and then reschedule
-          alts -> do
-                forM alts $ \alt@(FoundBodyAlt {foundBodyAltBacktrackPrio=bprio}) -> do
-                  log (Just alt)
-                  (backtrack $ nextwork bprio alt) >>= slvSchedule bprio
-                slvScheduleRun
-
-      where
-        log alt = do
-          let a = (fmap (rbodyaltBody . foundBodyAltAlt) alt)
-          let step = SolveStep chr matchSubst a [] [] -- TODO: Set stepNewTodo, stepNewDone (last two arguments)
-          fstl ^* chrgstTrace =$: (step:)
-        nextwork bprio alt@(FoundBodyAlt {foundBodyAltAlt=(RuleBodyAlt {rbodyaltBody=body})}) = do
-          -- set prio for this alt
-          sndl ^* chrbstBacktrackPrio =: bprio
-          -- fresh vars for unbound body metavars
-          freshSubst <- slvFreshSubst freeHeadVars body
-          -- add each constraint from the body, applying the meta var subst
-          newWkInxs <- forM body $ addConstraintAsWork . ((freshSubst |+> matchSubst) `varUpd`)
-          -- mark this combi of chr and work as visited
-          let matchedCombi = MatchedCombi ci workInxs
-          sndl ^* chrbstMatchedCombis =$: Set.insert matchedCombi
-          -- add this reduction step as being taken
-          sndl ^* chrbstReductionSteps =$: (SolverReductionStep matchedCombi (foundBodyAltInx alt) (Map.unionsWith (++) $ map (\(k,v) -> Map.singleton k [v]) $ newWkInxs) :)
-          -- take next step
-          slv
-
-    -- misc utils
-
--- | Fresh variables in the form of a subst
-slvFreshSubst
-  :: forall c g bp p s e m x .
-     ( MonoBacktrackPrio c g bp p s e m
-     , ExtrValVarKey x ~ ExtrValVarKey (VarLookupVal s)
-     , VarExtractable x
-     ) => Set.Set (ExtrValVarKey x)
-       -> x
-       -> CHRMonoBacktrackPrioT c g bp p s e m s
-slvFreshSubst except x = 
-    fmap (foldr (|+>) varlookupEmpty) $
-      forM (Set.toList $ varFreeSet x `Set.difference` except) $ \v ->
-        modifyAndGet (sndl ^* chrbstFreshVar) (freshWith $ Just v) >>= \v' -> return $ (varlookupSingleton v (varTermMkKey v') :: s)
-
--- | Lookup work in a store part of the global state
-slvLookup
-  :: ( MonoBacktrackPrio c g bp p s e m
-     , Ord x
-     ) => CHRKey c                                   -- ^ work key
-       -> Lens (CHRGlobState c g bp p s e m) (CHRTrie' c [x])
-       -> CHRMonoBacktrackPrioT c g bp p s e m [x]
-slvLookup key t =
-    (getl $ fstl ^* t) >>= \t -> do
-      let lkup how = concat $ TreeTrie.lookupResultToList $ TreeTrie.lookupPartialByKey how key t
-      return $ Set.toList $ Set.fromList $ lkup TTL_WildInTrie ++ lkup TTL_WildInKey
-
-{-
-      Actual type: CHRGlobState
-                     cnstr1 guard1 bprio1 prio1 subst1 env1 m1
-                   :-> CHRTrie' cnstr1 [CHRConstraintInx]
-
-    lkup how k = do
-      fmap (concat . TreeTrie.lookupResultToList . TreeTrie.lookupPartialByKey how k) $ getl $ fstl ^* chrgstWorkStore ^* wkstoreTrie
--}
-
--- | Extract candidates matching a CHRKey.
---   Return a list of CHR matches,
---     each match expressed as the list of constraints (in the form of Work + Key) found in the workList wlTrie, thus giving all combis with constraints as part of a CHR,
---     partititioned on before or after last query time (to avoid work duplication later)
-slvCandidate
-  :: ( MonoBacktrackPrio c g bp p s e m
-     -- , Ord (TTKey c), PP (TTKey c)
-     ) => WorkInxSet                           -- ^ active in queue
-       -> Set.Set MatchedCombi                      -- ^ already matched combis
-       -> WorkInx                                   -- ^ work inx
-       -> StoredCHR c g bp p                        -- ^ found chr for the work
-       -> Int                                       -- ^ position in the head where work was found
-       -> CHRMonoBacktrackPrioT c g bp p s e m
-            ( [[WorkInx]]                           -- All matches of the head, unfiltered w.r.t. deleted work
-            )
-slvCandidate waitingWk alreadyMatchedCombis wi (StoredCHR {_storedHeadKeys = ks, _storedChrInx = ci}) headInx = do
-    let [ks1,_,ks2] = splitPlaces [headInx, headInx+1] ks
-    ws1 <- forM ks1 lkup
-    ws2 <- forM ks2 lkup
-    return $ filter (\wi ->    all (`IntSet.member` waitingWk) wi
-                            && Set.notMember (MatchedCombi ci wi) alreadyMatchedCombis)
-           $ combineToDistinguishedEltsBy (==) $ ws1 ++ [[wi]] ++ ws2
-  where
-    lkup k = slvLookup k (chrgstWorkStore ^* wkstoreTrie)
-{-
-    lkup how k = do
-      fmap (concat . TreeTrie.lookupResultToList . TreeTrie.lookupPartialByKey how k) $ getl $ fstl ^* chrgstWorkStore ^* wkstoreTrie
--}
-
--- | Match the stored CHR with a set of possible constraints, giving a substitution on success
-slvMatch
-  :: ( {-
-       CHREmptySubstitution s
-     , VarLookupCmb s s
-     , -}
-       MonoBacktrackPrio c g bp p s env m
-     {- these below should not be necessary as they are implied (via superclasses) by MonoBacktrackPrio, but deeper nested superclasses seem not to be picked up...
-     -}
-     , CHRMatchable env c s
-     , CHRCheckable env g s
-     , CHRMatchable env bp s
-     -- , CHRPrioEvaluatable env p s
-     , CHRPrioEvaluatable env bp s
-     -- , CHRBuiltinSolvable env b s
-     -- , PP s
-     ) => env
-       -> StoredCHR c g bp p
-       -> [c]
-       -> Int                                       -- ^ position in the head where work was found, on that work specifically we might have to wait
-       -> CHRMonoBacktrackPrioT c g bp p s env m (Maybe (FoundSlvMatch c g bp p s))
-slvMatch env chr@(StoredCHR {_storedChrRule = Rule {rulePrio = mbpr, ruleHead = hc, ruleGuard = gd, ruleBacktrackPrio = mbbpr, ruleBodyAlts = alts}}) cnstrs headInx = do
-    subst <- getl $ sndl ^* chrbstSolveSubst
-    curbprio <- fmap chrPrioLift $ getl $ sndl ^* chrbstBacktrackPrio
-    return $ fmap (\(s,ws) -> FoundSlvMatch s freevars ws (FoundMatchSortKey (fmap ((,) s) mbpr) (Set.size ws) (_storedChrInx chr))
-                    [ FoundBodyAlt i bp a | (i,a) <- zip [0..] alts, let bp = maybe minBound (chrPrioEval env s) $ rbodyaltBacktrackPrio a
-                    ])
-           $ (\m -> chrmatcherRun m (emptyCHRMatchEnv {chrmatchenvMetaMayBind = (`Set.member` freevars)}) subst)
-           $ sequence_
-           $ prio curbprio ++ matches ++ checks
-  where
-    prio curbprio = maybe [] (\bpr -> [chrMatchToM env bpr curbprio]) mbbpr
-    matches = zipWith3 (\i h c -> chrMatchAndWaitToM (i == headInx) env h c) [0::Int ..] hc cnstrs
-    -- ignoreWait 
-    checks  = map (chrCheckM env) gd
-    freevars = Set.unions [varFreeSet hc, maybe Set.empty varFreeSet mbbpr]
-
--------------------------------------------------------------------------------------------
---- Instances: Serialize
--------------------------------------------------------------------------------------------
-
-{-
-instance (Ord (TTKey c), Serialize (TTKey c), Serialize c, Serialize g, Serialize b, Serialize p) => Serialize (CHRStore c g b p) where
-  sput (CHRStore a) = sput a
-  sget = liftM CHRStore sget
-  
-instance (Serialize c, Serialize g, Serialize b, Serialize p, Serialize (TTKey c)) => Serialize (StoredCHR c g bp p) where
-  sput (StoredCHR a b c d) = sput a >> sput b >> sput c >> sput d
-  sget = liftM4 StoredCHR sget sget sget sget
-
--}
diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Visualizer.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Visualizer.hs
deleted file mode 100644
--- a/src/UHC/Util/CHR/Solve/TreeTrie/Visualizer.hs
+++ /dev/null
@@ -1,568 +0,0 @@
-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
-
-module UHC.Util.CHR.Solve.TreeTrie.Visualizer
-  ( chrVisualize
-  )
-  where
-
-import           Prelude
-import           Data.Maybe
-import           Data.List
-import qualified Data.Map as Map
-import           UHC.Util.Pretty
-import           UHC.Util.PrettySimple
-import           UHC.Util.CHR.Rule
-import           UHC.Util.CHR.GTerm.Parser
-import           UHC.Util.CHR.Solve.TreeTrie.Mono
-import           UHC.Util.CHR.Solve.TreeTrie.MonoBacktrackPrio as MBP
-import           UHC.Util.CHR.Solve.TreeTrie.Examples.Term.AST
-import           UHC.Util.CHR.Solve.TreeTrie.Internal
-import           UHC.Util.CHR.Solve.TreeTrie.Internal.Shared
-import           UHC.Util.Substitutable
-import           Data.Graph.Inductive.Graph
-import           Data.Graph.Inductive.Tree
-
-sortGroupOn :: Ord b => (a -> b) -> [a] -> [[a]]
-sortGroupOn f = construct . sortOn f
-  where
-    construct []     = []
-    construct (y:ys) = group : construct rest
-      where
-        group = y : takeWhile ((f y ==) . f) ys
-        rest  =     dropWhile ((f y ==) . f) ys
-
-data NodeData
-  -- Applied rule with first alt (if it exists)
-  = NodeRule 
-    { nrLayer       :: Int
-    , nrColumn      :: Int
-    , nrName        :: String
-    , nrRuleVars    :: [Tm]
-    , nrFirstAlt    :: Maybe C
-    }
-  -- Additional alts of a rule
-  | NodeAlt
-    { naLayer       :: Int
-    , naColumn      :: Int
-    , naConstraint  :: C
-    }
-  -- Added node to make a proper layered graph
-  -- A proper layered graph is a graph in which all edges
-  -- go from a layer to the next layer. To satisfy this,
-  -- we add synthesized nodes on edges that do not skip one
-  -- or more layers
-  | NodeSynthesized 
-    { nsLayer       :: Int
-    , nsColumn      :: Int
-    , nsEdgeKind    :: EdgeKind
-    }
-
-data EdgeKind
-  = EdgeGuard -- Usage of term in guard of rule.
-  | EdgeHead  -- Usage of term in head of rule.
-  | EdgeUnify -- Usage of some term that required unification of this node.
-  | EdgeAlt   -- Link between NodeRule and NodeAlt. Both nodes have same layer.
-  deriving Eq
-
-type Node' = LNode NodeData
--- | Edge has a kind and a bool that says whether this edge is
---   the last edge of a sequence of edges. The last edge does not
---   end in a synthesized node, the others do.
-type Edge' = LEdge (EdgeKind, Bool)
-type NodeEdge = (Node', Node', EdgeKind, Bool)
-
-asEdge :: NodeEdge -> Edge'
-asEdge ((from, _), (to, _), kind, isLast) = (from, to, (kind, isLast))
-
--- | Gets the layer of a node
-nodeLayer :: Node' -> Int
-nodeLayer (_, NodeRule{nrLayer = layer})        = layer
-nodeLayer (_, NodeAlt{naLayer = layer})         = layer
-nodeLayer (_, NodeSynthesized{nsLayer = layer}) = layer
-
--- | Gets the column of a node
-nodeColumn :: Node' -> Int
-nodeColumn (_, NodeRule{nrColumn = col})        = col
-nodeColumn (_, NodeAlt{naColumn = col})         = col
-nodeColumn (_, NodeSynthesized{nsColumn = col}) = col
-
--- | Sets the column of a node
-nodeSetColumn :: Node' -> Int -> Node'
-nodeSetColumn (n, d@NodeRule{}) col        = (n, d{nrColumn = col})
-nodeSetColumn (n, d@NodeAlt{}) col         = (n, d{naColumn = col})
-nodeSetColumn (n, d@NodeSynthesized{}) col = (n, d{nsColumn = col})
-
--- | A map between a term, and the location where it was found combined
---   with the required unifications
-type NodeMap = Map.Map Tm (Node', [Node'])
--- | Contains all data needed to build the graph, during traversal of
---   the solve trace
-data BuildState = BuildState [Node'] [NodeEdge] NodeMap Int Int
-emptyBuildState :: BuildState
-emptyBuildState = BuildState [] [] Map.empty 0 0
-
--- | Gives all terms that follow after a unification
-replaceInTm :: Tm -> Tm -> Tm -> [Tm]
-replaceInTm a b tm
-  | tm == a || tm == b = [a, b]
-  | otherwise          = case tm of
-    Tm_Con name tms -> fmap (Tm_Con name) (replaceList tms)
-    Tm_Lst tms ltm  -> do
-      tms' <- replaceList tms
-      ltm' <- replaceMaybe ltm
-      return $ Tm_Lst tms' ltm'
-    Tm_Op op tms    -> fmap (Tm_Op op) (replaceList tms)
-    x               -> [x]
-    where
-      replaceList = sequence . fmap (replaceInTm a b)
-      replaceMaybe Nothing  = [Nothing]
-      replaceMaybe (Just y) = fmap Just $ replaceInTm a b y
-
--- | Gives all terms in a constraint
-tmsInC :: C -> [Tm]
-tmsInC (C_Con s tms) = [Tm_Con s tms]
-tmsInC _             = []
-
--- | Gives all terms in a guard
-tmsInG :: G -> [Tm]
-tmsInG (G_Tm tm) = tmsInTm tm
-tmsInG _         = []
-
-tmsInTm :: Tm -> [Tm]
-tmsInTm tm = tm : children tm
-  where
-    children (Tm_Lst as Nothing)  = as
-    children (Tm_Lst as (Just a)) = as ++ [a]
-    children _                    = [] 
-
--- | Finds all terms that were used for this rule
---   Used by visualizer to draw edges to the origin of
---   these rules.
-precedentTms :: Rule C G P P -> [(Tm, EdgeKind)]
-precedentTms rule
-  =  fmap (\n -> (n, EdgeHead))  (concatMap tmsInC $ ruleHead rule)
-  ++ fmap (\n -> (n, EdgeGuard)) (concatMap tmsInG $ ruleGuard rule)
-
--- | Adds the constraint (of an alt) to the NodeMap
-addConstraint :: C -> Node' -> NodeMap -> NodeMap
-addConstraint (CB_Eq a b)   = addUnify a b
-addConstraint (C_Con s tms) = addTerm $ Tm_Con s tms
-addConstraint c             = const id
-
-addTerm :: Tm -> Node' -> NodeMap -> NodeMap
-addTerm tm node =  Map.insert tm (node, [])
-
-addUnify :: Tm -> Tm -> Node' -> NodeMap -> NodeMap
-addUnify a b node map = Map.foldlWithKey cb map map
-  where
-    cb :: NodeMap -> Tm -> (Node', [Node']) -> NodeMap
-    cb map' tm (n, nodes) = foldl (\map'' key -> Map.insertWith compare key (n, node : nodes) map'') map' (replaceInTm a b tm)
-    compare x@(_, nodes1) y@(_, nodes2)
-      | length nodes1 <= length nodes2 = x
-      | otherwise                      = y
-
--- | Generates nodes and edges for a SolveStep.
---   Stores the resulting terms in the NodeMap.
-stepToNodes :: BuildState -> SolveStep' C (MBP.StoredCHR C G P P) S -> BuildState
-stepToNodes state@(BuildState _ _ nodeMap nodeId layer) step
-  = BuildState
-    nodes
-    edges''
-    nodeMap'
-    nodeId'
-    layer'
-  where
-    schr = stepChr step
-    rule = storedChrRule' schr
-    updRule = varUpd (stepSubst step) rule
-    alt = maybe [] (fmap $ varUpd $ stepSubst step) $ stepAlt step
-    (BuildState nodes edges' nodeMap' nodeId' layer', primaryNode) =
-      createNodes
-        (maybe "[untitled]" id (ruleName rule))
-        (Map.elems (stepSubst step))
-        alt
-        state
-    edges'' =
-      ( fmap (\(n, kind) -> (n, primaryNode, kind, True))
-        $ concatMap (\(n, ns, kind) -> (n, kind) : fmap (\x -> (x, EdgeUnify)) ns)
-        $ mapMaybe
-          (\(tm, kind) -> fmap
-            (\(n, ns) -> (n, ns, kind))
-            (Map.lookup tm nodeMap))
-          (precedentTms updRule)
-      )
-      ++ edges'
-
-createNodes :: String -> [Tm] -> [C] -> BuildState -> (BuildState, Node')
-createNodes name vars alts (BuildState previousNodes previousEdges nodeMap nodeId layer)
-  = ( BuildState (nodes ++ previousNodes) (edges ++ previousEdges) nodeMap' (nodeId + max 1 (length alts)) (layer + 1)
-    , primaryNode
-    )
-  where
-    primaryNode =
-      (nodeId, NodeRule
-        { nrLayer    = layer
-        , nrColumn   = 0
-        , nrName     = name
-        , nrRuleVars = vars
-        , nrFirstAlt = listToMaybe alts
-        }
-      )
-    nodes = primaryNode : altNodes
-    altTms = concatMap tmsInC alts
-    nodeMap' = foldl updateMap nodeMap nodes
-    -- Updates node map for a new node
-    updateMap :: NodeMap -> Node' -> NodeMap
-    updateMap map node@(_, NodeRule{ nrFirstAlt = Just alt }) = addConstraint alt node map
-    updateMap map node@(_, NodeAlt{ naConstraint = alt }) = addConstraint alt node map
-    updateMap map _ = map
-    
-    altNode (constraint, i) = (nodeId + i, NodeAlt layer 0 constraint)
-    altNodes = fmap altNode (drop 1 $ addIndices alts)
-    edges = (fmap (\n -> (primaryNode, n, EdgeAlt, True)) altNodes)
-
--- | Adds synthesized nodes to create a proper layered graph
-createSynthesizedNodes :: [Node'] -> [NodeEdge] -> Int -> ([NodeEdge], [Node'])
-createSynthesizedNodes nodes es firstNode
-  = create es firstNode [] []
-  where
-    create :: [NodeEdge] -> Int -> [NodeEdge] -> [Node'] -> ([NodeEdge], [Node'])
-    create ((edge@(from, to, kind, _)):edges) id accumEdges accumNodes
-      = create edges id' (es ++ accumEdges) (ns ++ accumNodes)
-      where
-        (es, ns, id') = split (nodeLayer from) edge id
-    create _ _ accumEdges accumNodes = (accumEdges, accumNodes)
-    split :: Int -> NodeEdge -> Int -> ([NodeEdge], [Node'], Int)
-    split fromLayer edge@(from, to, kind, _) id
-      | fromLayer + 1 >= nodeLayer to = ([edge], [], id)
-      | otherwise                     =
-        ( (from, node, kind, False) : edges',
-          node : nodes',
-          id'
-        )
-        where
-          node = (id, (NodeSynthesized (fromLayer + 1) 0 kind))
-          (edges', nodes', id') = split (fromLayer + 1) (node, to, kind, True) (id + 1)
-
--- | Creates a graph with the visualization
-createGraph :: [C] -> [SolveStep' C (MBP.StoredCHR C G P P) S] -> Gr NodeData (EdgeKind, Bool)
-createGraph query steps = mkGraph sortedLayers (fmap asEdge edges)
-  where
-    -- | Sort the layers by giving each node in a layer an unique nodeColumn value
-    sortedLayers = sortedFirstLayer ++ sortNodes maxLayerSize (sortedFirstLayer : layers) layeredEdges
-    -- | Set the nodeColumn values of each of the nodes in the query (the query forms the first layer)
-    sortedFirstLayer = uniqueColumns firstLayer ((maxLayerSize - length firstLayer) `div` 2)
-    -- | Extracting [[Node']] from layerNodes
-    firstLayer : layers = sortGroupOn nodeLayer nodes
-    -- firstLayer : layers = Map.elems $ layerNodes nodes
-    -- | For each layer we create a list with the nodes in that layer
-    -- layerNodes :: [Node'] -> Map.Map Int [Node']
-    -- layerNodes ns = foldl (\m x -> Map.insertWith (++) (nodeLayer x) [x] m) Map.empty ns
-    (state, _) = createNodes "?" [] query emptyBuildState
-    BuildState nodes' edges' _ id _ = foldr (flip stepToNodes) state steps
-    (edges, synNodes) = createSynthesizedNodes nodes' edges' id
-    nodes = nodes' ++ synNodes
-    maxLayerSize = maximum $ fmap length (firstLayer : layers)
-    edgesCrossLayer = filter (\(from, to, _, _) -> nodeLayer from /= nodeLayer to) edges
-    layeredEdges = sortGroupOn (nodeLayer . fst') edgesCrossLayer
-
--- | Sort the nodes using the median heuristic
--- | The first layer is left as it was, the second layer is sorted using the first etc.
-sortNodes :: Int -> [[Node']] -> [[NodeEdge]] -> [Node']
-sortNodes _ (x:[]) _ = []
-sortNodes maxLayerSize (x:xs:xss) e = medianHeurstic maxLayerSize x xs edges ++ sortNodes maxLayerSize (xs:xss) rest
-  where
-    (edges, rest) =
-      if null e then
-        ([], [])
-      else if (nodeLayer $ fst' $ head $ head e) == nodeLayer (head x) then
-        (head e, tail e)
-      else
-        ([], e)
-
--- | lowerLayer is the layer to be sorted, upperLayer is assumed to be sorted
--- | The maxLayerSize is used to center the graph (by altering the value given to uniqueColumns)
--- | Documentation for the median heuristic:
--- | https://cs.brown.edu/~rt/gdhandbook/chapters/hierarchical.pdf
--- | http://www.cs.usyd.edu.au/~shhong/fab.pdf
--- | https://books.google.nl/books?id=6hfsCAAAQBAJ&lpg=PA28&dq=median%20heuristic%20sorting%20vertices&hl=nl&pg=PA28#v=onepage&q&f=false
-medianHeurstic :: Int -> [Node'] -> [Node'] -> [NodeEdge] -> [Node']
-medianHeurstic maxLayerSize upperLayer lowerLayer e = uniqueColumns sortedMedianList ((maxLayerSize - length lowerLayer) `div` 2)
-  where
-    -- | The medianList sorted on the median values
-    sortedMedianList = sortOn nodeColumn medianList
-    -- | The list of median values for each of the nodes in lowerLayer
-    medianList = map (\x -> nodeSetColumn x (median x)) lowerLayer
-    -- | The median value of the x coördinates of the neighbors
-    median n
-      | neighborCount == 0 = 0
-      | otherwise          = coords !! (ceiling (realToFrac neighborCount / 2) - 1)
-      where
-        coords = coordinates n
-        neighborCount = length coords
-    -- | The values of the x coördinates of the neighbors
-    coordinates n = map nodeColumn (neighbors n)
-    -- | The neighbor nodes of the given Node' n (on a higher layer)
-    neighbors n = map (fst') (edges n)
-    -- | All the edges connected to given Node' n
-    edges n = filter (\(_, (id, _), _, _) -> id == fst n) e
-
--- | Ensure that each Node' has an unique nodeColumn (the x coördinate)
--- | The value of the nodeColumn is set to i
-uniqueColumns :: [Node'] -> Int -> [Node']
-uniqueColumns (n:ns) i = nodeSetColumn n i : uniqueColumns ns (i + 1)
-uniqueColumns _ _ = []
-
-fst' :: (a, b, c, d) -> a
-fst' (a, _, _, _) = a
-
--- | Creates a HTML tag
-tag :: String -> PP_Doc -> PP_Doc -> PP_Doc
-tag name attr content = (text ("<" ++ name)) >|< attributes attr >|< body content
-  where
-    attributes Emp = Emp
-    attributes a   = text " " >|< a
-    body Emp       = text " />"
-    body content   = text ">" >|< content >|< text ("</" ++ name ++ ">")
-
--- | Creates a HTML tag without attributes
-tag' :: String -> PP_Doc -> PP_Doc
-tag' name = tag name Emp
-
--- | Add indices to an array as a tuple with value and index
-addIndices :: [a] -> [(a, Int)]
-addIndices = flip zip [0..]
-
--- | Generates HTML for a node
-showNode :: (Node' -> (Int, Int)) -> Node' -> PP_Doc
-showNode pos node@(_, NodeRule{nrLayer = layer, nrName = name, nrRuleVars = vars, nrFirstAlt = alt}) = tag "div"
-  (
-    text "class=\"rule\" style=\"top: "
-    >|< pp (y + 10) 
-    >|< text "px; left: "
-    >|< pp x
-    >|< text "px;\""
-  )
-  (
-    tag "span" (text "class=\"" >|< className >|< text "\"") (
-      (text name)
-      >|< (hlist (fmap ((" " >|<) . pp) vars))
-    )
-    >|< tag' "br" Emp
-    >|< text "&#8627;"
-    >|< tag "span" (text "class=\"rule-alt\"") altText
-  )
-  where
-    (x, y) = pos node
-    altText = maybe (text ".") pp alt
-    className = text "rule-text"
-    showUsage name var = tag "div" (text $ "class=\"" ++ className ++ "\"") (text " ")
-      where
-        className = name ++ " var-" ++ var
-showNode pos node@(_, NodeAlt{ naConstraint = constraint }) = tag "div"
-  (
-    text "class=\"rule-additional-alt\" style=\"top: "
-    >|< pp (y + 10)
-    >|< text "px; left: "
-    >|< pp x
-    >|< text "px;\""
-  )
-  (
-    text "&#8627;"
-    >|< tag "span" (text "class=\"rule-alt\"") (pp constraint)
-  )
-  where
-    (x, y) = pos node
-showNode _ (_, NodeSynthesized{}) = Emp
-
--- | Generates HTML for an edge
-showEdge :: (Node -> (Int, Int)) -> Edge' -> PP_Doc
-showEdge pos (from, to, (kind, isEnd)) =
-  if kind == EdgeAlt then
-    -- Edge between rule and alt of same rule
-    tag "div"
-      (
-        text "class=\"edge-alt\" style=\"top: "
-        >|< pp y1
-        >|< "px; left: "
-        >|< pp (min x1 x2)
-        >|< "px; width: "
-        >|< abs (x2 - x1 - 16)
-        >|< "px;\""
-      )
-      (text " ")
-  else
-    tag "div"
-      (
-        text "class=\"edge-ver "
-        >|< text className
-        >|< text "\" style=\"top: "
-        >|< pp (y1 + 35)
-        >|< "px; left: "
-        >|< pp x1
-        >|< "px; height: "
-        >|< (y2 - y1 - 60 - 6)
-        >|< "px;\""
-      )
-      (text " ")
-    >|< tag "div"
-      (
-        text "class=\"edge-hor"
-        >|< text (if x2 > x1 then " edge-hor-left " else if x2 < x1 then " edge-hor-right " else " edge-hor-no-curve ")
-        >|< text className
-        >|< text "\" style=\"top: "
-        >|< pp (y2 - 19)
-        >|< "px; left: "
-        >|< pp (if x1 < x2 then x1 else x2 + (if isEnd then 0 else (abs (x2 - x1) + 1) `div` 2))
-        >|< "px; width: "
-        >|< pp (abs (x2 - x1) `div` (if isEnd then 1 else 2))
-        >|< "px;\""
-      )
-      (text " ")
-    >|< (if isEnd then Emp else tag "div"
-        (
-          text "class=\"edge-end edge-end-"
-          >|< text (if x2 > x1 then "left " else if x2 < x1 then "right " else "no-curve ")
-          >|< text className
-          >|< text "\" style=\"top: "
-          >|< pp (y2 - 3 + 11)
-          >|< "px; left: "
-          >|< pp (if x1 < x2 then (x1 + x2) `div` 2 + 6 else x2)
-          >|< pp "px; width: "
-          >|< pp (if x1 == x2 then 0 else ((abs (x2 - x1) + 1) `div` 2) - 6)
-          >|< "px;\""
-        )
-        (text " ")
-    )
-  where
-    (x1, y1)  = pos from
-    (x2, y2)  = pos to
-    className = case kind of
-      EdgeAlt   -> ""
-      EdgeGuard -> "edge-guard"
-      EdgeHead  -> "edge-head"
-      EdgeUnify -> "edge-unify"
-
--- | Creates a visualization for the given query and solve trace.
---   Output is a PP_Doc containing a HTML file.
-chrVisualize :: [C] -> SolveTrace' C (MBP.StoredCHR C G P P) S -> PP_Doc
-chrVisualize query trace = tag' "html" $
-  tag' "head" (
-    tag' "title" (text "CHR visualization")
-    >|< tag' "style" styles
-  )
-  >|< tag' "body" (
-    body
-  )
-  where
-    graph = createGraph query trace
-    body = ufold reduce Emp graph >|< hlist (fmap (showEdge posId) $ labEdges graph)
-    reduce (inn, id, node, out) right = showNode pos (id, node) >|< right
-    nodeCount = length $ nodes graph
-    pos :: Node' -> (Int, Int)
-    pos n = ((nodeColumn n) * 200, (nodeLayer n) * 60)
-    posId :: Node -> (Int, Int)
-    posId node = pos (node, fromJust $ lab graph node)
-
--- | The stylesheet used in the visualization.
-styles :: PP_Doc
-styles =
-  text "body {\n\
-       \  font-size: 9pt;\n\
-       \  font-family: Arial;\n\
-       \}\n\
-       \.rule {\n\
-       \  position: absolute;\n\
-       \  white-space: nowrap;\n\
-       \}\n\
-       \.rule-text {\n\
-       \  border: 1px solid #aaa;\n\
-       \  background-color: #fff;\n\
-       \  display: inline-block;\n\
-       \  padding: 2px;\n\
-       \  margin: 3px 1px 0;\n\
-       \  min-width: 30px;\n\
-       \  text-align: center;\n\
-       \}\n\
-       \.rule-alt {\n\
-       \  display: inline-block;\n\
-       \  color: #A89942;\n\
-       \  background: #fff;\n\
-       \}\n\
-       \.rule-additional-alt {\n\
-       \  position: absolute;\n\
-       \  white-space: nowrap;\n\
-       \  margin-top: 24px;\n\
-       \}\n\
-       \.edge-ver {\n\
-       \  position: absolute;\n\
-       \  width: 0px;\n\
-       \  border-left: 6px solid #578999;\n\
-       \  opacity: 0.4;\n\
-       \  margin-left: 15px;\n\
-       \  margin-top: 9px;\n\
-       \  z-index: -1;\n\
-       \}\n\
-       \.edge-hor {\n\
-       \  position: absolute;\n\
-       \  height: 27px;\n\
-       \  border-bottom: 6px solid #578999;\n\
-       \  opacity: 0.4;\n\
-       \  margin-left: 15px;\n\
-       \  margin-top: 8px;\n\
-       \  z-index: -1;\n\
-       \}\n\
-       \.edge-diag {\n\
-       \  transform-origin: 50% 50%;\n\
-       \  position: absolute;\n\
-       \  height: 6px;\n\
-       \}\n\
-       \.edge-hor-left {\n\
-       \  border-bottom-left-radius: 100% 33px;\n\
-       \  border-left: 6px solid #578999;\n\
-       \}\n\
-       \.edge-hor-right {\n\
-       \  border-bottom-right-radius: 100% 33px;\n\
-       \  border-right: 6px solid #578999;\n\
-       \}\n\
-       \.edge-hor-no-curve {\n\
-       \  border-right: 6px solid #578999;\n\
-       \}\n\
-       \.edge-end {\n\
-       \  position: absolute;\n\
-       \  height: 27px;\n\
-       \  width: 16px;\n\
-       \  border-top: 6px solid #578999;\n\
-       \  opacity: 0.4;\n\
-       \  margin-left: 15px;\n\
-       \  margin-top: 8px;\n\
-       \  z-index: -1;\n\
-       \}\n\
-       \.edge-end-left {\n\
-       \  border-top-right-radius: 100% 33px;\n\
-       \  border-right: 6px solid #578999;\n\
-       \}\n\
-       \.edge-end-no-curve {\n\
-       \  border-right: 6px solid #578999;\n\
-       \  margin-top: 14px;\n\
-       \  height: 21px;\n\
-       \}\n\
-       \.edge-end-right {\n\
-       \  border-top-left-radius: 100% 33px;\n\
-       \  border-left: 6px solid #578999;\n\
-       \}\n\
-       \.edge-guard {\n\
-       \  border-color: #69B5A7;\n\
-       \}\n\
-       \.edge-unify {\n\
-       \  border-color: #8CBF7A;\n\
-       \}\n\
-       \.edge-alt {\n\
-       \  height: 1px;\n\
-       \  background-color: #aaa;\n\
-       \  position: absolute;\n\
-       \  margin-top: 19px;\n\
-       \  z-index: -1;\n\
-       \  padding-right: 22px;\n\
-       \}\n\
-       \"
diff --git a/src/UHC/Util/CHR/Types.hs b/src/UHC/Util/CHR/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/UHC/Util/CHR/Types.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-------------------------------------------------------------------------------------------
+--- Some shared types
+-------------------------------------------------------------------------------------------
+
+module UHC.Util.CHR.Types
+  ( IVar
+  
+  , VarToNmMp
+  , emptyVarToNmMp
+  
+  , NmToVarMp
+  , emptyNmToVarMp
+  )
+  where
+
+import qualified Data.Map                   as Map
+import qualified Data.IntMap                as IntMap
+
+-------------------------------------------------------------------------------------------
+--- Name <-> Var mapping
+-------------------------------------------------------------------------------------------
+
+type IVar      = IntMap.Key
+
+type VarToNmMp = IntMap.IntMap   String
+type NmToVarMp = Map.Map         String  IVar
+
+emptyVarToNmMp :: VarToNmMp = IntMap.empty
+emptyNmToVarMp :: NmToVarMp = Map.empty
diff --git a/src/UHC/Util/DependencyGraph.hs b/src/UHC/Util/DependencyGraph.hs
--- a/src/UHC/Util/DependencyGraph.hs
+++ b/src/UHC/Util/DependencyGraph.hs
@@ -51,8 +51,10 @@
 instance (Ord n,PP n) => PP (DpdGr n) where
   pp g = "DpdGr" >#< ("topsort:" >#< ppCommas (dgTopSort g) >-< "scc   :" >#< ppBracketsCommas (dgSCC g) >-< "edges  :" >#< (ppBracketsCommas $ map (\(n,_,ns) -> n >|< ":" >|< ppBracketsCommas ns) $ dgEdges $ g))
 
+{- is present in fgl lib
 instance Show (SCC n) where
   show _ = "SCC"
+-}
 
 instance PP n => PP (SCC n) where
   pp (AcyclicSCC n ) = "ASCC" >#< n
diff --git a/src/UHC/Util/FastSeq.hs b/src/UHC/Util/FastSeq.hs
--- a/src/UHC/Util/FastSeq.hs
+++ b/src/UHC/Util/FastSeq.hs
@@ -1,162 +1,6 @@
 module UHC.Util.FastSeq
-  ( FastSeq((:++:),(::+:),(:+::))
-  , Seq
-  , isEmpty, null
-  , empty
-  , size
-  , singleton
-  , toList, fromList
-  , map
-  , union, unions
-  , firstNotEmpty
+  ( module CHR.Data.FastSeq
   )
   where
 
-import           Prelude hiding (null,map)
-import           Data.Monoid
--- import qualified Data.ListLike as LL
-import qualified Data.List as L
-import qualified UHC.Util.Utils as U
-
--------------------------------------------------------------------------
--- Fast sequence, i.e. delayed concat 'trick'
--------------------------------------------------------------------------
-
-infixr 5 :++:, :+::
-infixl 5 ::+:
-
-data FastSeq a
-  = !(FastSeq a) :++: !(FastSeq a)
-  |          !a  :+:: !(FastSeq a)
-  | !(FastSeq a) ::+:          !a
-  | FSeq    !a
-  | FSeqL   ![a]
-  | FSeqNil
-
-type Seq a = FastSeq a
-
-empty :: FastSeq a
-empty = FSeqNil
-
--------------------------------------------------------------------------
--- Instances
--------------------------------------------------------------------------
-
-instance Monoid (FastSeq a) where
-  mempty  = empty
-  mappend = union
-  mconcat = unions
-
-{-
-instance LL.FoldableLL (FastSeq a) a where
-  foldl op e seq = 
-
-instance LL.ListLike (FastSeq a) a where
--}
-
--------------------------------------------------------------------------
--- Observations
--------------------------------------------------------------------------
-
-isEmpty, null :: FastSeq a -> Bool
-isEmpty FSeqNil      = True
-isEmpty (FSeqL x   ) = L.null x
-isEmpty (FSeq  _   ) = False
-isEmpty (x1 :++: x2) = isEmpty x1 && isEmpty x2
-isEmpty (x1 :+:: x2) = False
-isEmpty (x1 ::+: x2) = False
--- isEmpty sq           = L.null $ toList sq
-
-null = isEmpty
-
-size :: FastSeq a -> Int
-size FSeqNil      = 0
-size (FSeqL x   ) = length x
-size (FSeq  _   ) = 1
-size (x1 :++: x2) = size x1 + size x2
-size (x1 :+:: x2) = 1 + size x2
-size (x1 ::+: x2) = size x1 + 1
-
--------------------------------------------------------------------------
--- Construction
--------------------------------------------------------------------------
-
-singleton :: a -> FastSeq a
-singleton = FSeq
-
--------------------------------------------------------------------------
--- Deconstruction
--------------------------------------------------------------------------
-
--- | View as head and tail, if possible
-viewMbCons :: FastSeq a -> Maybe (a, FastSeq a)
-viewMbCons FSeqNil         = Nothing
-viewMbCons (FSeq  x)       = Just (x, FSeqNil)
-viewMbCons (FSeqL (h:t))   = Just (h, FSeqL t)
-viewMbCons (FSeqL []   )   = Nothing
-viewMbCons (h  :+:: t )    = Just (h, t)
-viewMbCons (i  ::+: l )    = maybe (Just (l, FSeqNil)) (\(h,t) -> Just (h, t ::+: l)) $ viewMbCons i
-viewMbCons (s1 :++: s2)    = maybe (viewMbCons s2) (\(h,t) -> Just (h, t :++: s2)) $ viewMbCons s1
-
-{-
--- | View as init and last, if possible
-viewMbSnoc :: FastSeq a -> Maybe (FastSeq a, a)
-viewMbSnoc FSeqNil         = Nothing
-viewMbSnoc (FSeqL (h:t))   = Just (h, FSeqL t)
-viewMbSnoc (FSeqL []   )   = Nothing
-viewMbSnoc (h  :+:: t )    = Just (h, t)
-viewMbSnoc (i  ::+: l )    = maybe (Just (l, FSeqNil)) (\(h,t) -> Just (h, t ::+: l)) $ viewMbSnoc i
-viewMbSnoc (s1 :++: s2)    = maybe (viewMbSnoc s2) (\(h,t) -> Just (h, t :++: s2)) $ viewMbSnoc s1
--}
-
-
--------------------------------------------------------------------------
--- Conversion
--------------------------------------------------------------------------
-
-fromList :: [a] -> FastSeq a
-fromList [] = FSeqNil
-fromList l  = FSeqL l
-
-toList :: FastSeq a -> [a]
-toList s
-  = a s []
-  where a FSeqNil      l = l
-        a (FSeq  x   ) l = x : l
-        a (FSeqL x   ) l = x L.++ l
-        a (x1 :++: x2) l = a x1 (a x2 l)
-        a (x1 :+:: x2) l = x1 : a x2 l
-        a (x1 ::+: x2) l = a x1 (x2 : l)
-
--------------------------------------------------------------------------
--- Map, ...
--------------------------------------------------------------------------
-
-map :: (a->b) -> FastSeq a -> FastSeq b
-map f FSeqNil      = FSeqNil
-map f (FSeq  x   ) = FSeq $ f x
-map f (FSeqL x   ) = FSeqL $ L.map f x
-map f (x1 :++: x2) = map f x1 :++: map f x2
-map f (x1 :+:: x2) =     f x1 :+:: map f x2
-map f (x1 ::+: x2) = map f x1 ::+:     f x2
-
--------------------------------------------------------------------------
--- Union
--------------------------------------------------------------------------
-
-union :: FastSeq a -> FastSeq a -> FastSeq a
-union FSeqNil FSeqNil = FSeqNil
-union FSeqNil s2      = s2
-union s1      FSeqNil = s1
-union s1      s2      = s1 :++: s2
-
-unions :: [FastSeq a] -> FastSeq a
-unions [s] =                           s
-unions  s  = L.foldr ( (:++:)) FSeqNil s
-
--------------------------------------------------------------------------
--- Misc
--------------------------------------------------------------------------
-
-firstNotEmpty :: [FastSeq x] -> FastSeq x
-firstNotEmpty = U.maybeHd empty id . filter (not . isEmpty)
+import CHR.Data.FastSeq
diff --git a/src/UHC/Util/Fresh.hs b/src/UHC/Util/Fresh.hs
--- a/src/UHC/Util/Fresh.hs
+++ b/src/UHC/Util/Fresh.hs
@@ -3,42 +3,8 @@
 -------------------------------------------------------------------------------------------
 
 module UHC.Util.Fresh
-  ( -- MonadFresh(..)
-    Fresh(..)
+  ( module CHR.Data.Fresh
   )
   where
 
-{-
-class Monad m => MonadFresh f m where
-  -- | Fresh single 'f'
-  fresh :: m f
-  fresh = freshInf
-
-  -- | Fresh infinite range of 'f'
-  freshInf :: m f
-  freshInf = fresh
--}
-
-class Fresh fs f where
-  -- | Fresh single 'f', and modifier 'upd' for freshly created value
-  freshWith :: Maybe f -> fs -> (f,fs)
-  freshWith = freshInfWith
-
-  -- | Fresh single 'f'
-  fresh :: fs -> (f,fs)
-  fresh = freshWith Nothing
-
-  -- | Fresh infinite range of 'f', and modifier 'upd' for freshly created value
-  freshInfWith :: Maybe f -> fs -> (f,fs)
-  freshInfWith = freshWith
-
-  -- | Fresh infinite range of 'f'
-  freshInf :: fs -> (f,fs)
-  freshInf = freshInfWith Nothing
-
-instance Fresh Int Int where
-  freshWith _ i = (i, i+1)
-
-instance Fresh Int String where
-  freshWith orig i = (maybe f (\o -> f ++ "_" ++ o) orig, i+1)
-    where f = "$" ++ show i
+import CHR.Data.Fresh
diff --git a/src/UHC/Util/Lens.hs b/src/UHC/Util/Lens.hs
--- a/src/UHC/Util/Lens.hs
+++ b/src/UHC/Util/Lens.hs
@@ -5,146 +5,10 @@
 {-# LANGUAGE TypeOperators, NoMonomorphismRestriction #-}
 
 module UHC.Util.Lens
-  ( (:->)
-  , Lens
-
-  -- * Access
-  
-  , (^*)
-
-  , (^.)
-  , (^=)
-  , (^$=)
-  
-  , (=.)
-  , (=:)
-  , (=$:)
-  , modifyAndGet
-  , getl
-  
-  -- * Misc
-  
-  , focus
-  
-  , mkLabel
-  
-  -- * Tuple accessors
-  , fstl
-  , sndl
-  , fst3l
-  , snd3l
-  , trd3l
-  
-  -- * Wrappers
-  
-  , isoMb
-  , isoMbWithDefault
+  ( module CHR.Data.Lens.FCLabels
 
   )
   where
 
-import           Prelude hiding ((.), id)
-import qualified Control.Monad.State as MS
-import           Control.Monad.Trans
-import           Control.Category
-
-import           Data.Label hiding (Lens)
-import qualified Data.Label.Base as L
-import           Data.Label.Monadic((=:), (=.), modifyAndGet)
-import qualified Data.Label.Monadic as M
-import qualified Data.Label.Partial as P
-
-import           UHC.Util.Utils
-
--- * Textual alias for (:->), avoiding TypeOperators
-type Lens a b = a :-> b
-
--- * Operator interface for composition
-
-infixl 9 ^*
--- | composition with a flipped reading
-(^*) :: (a :-> b) -> (b :-> c) -> (a :-> c)
-f1 ^* f2 = f2 . f1
-{-# INLINE (^*) #-}
-
-
--- * Operator interface for functional part (occasionally similar to Data.Lens)
-
-infixl 8 ^.
--- | functional getter, which acts like a field accessor
-(^.) :: a -> (a :-> b) -> b
-a ^. f = get f a
-{-# INLINE (^.) #-}
-
-infixr 4 ^=
--- | functional setter, which acts like a field assigner
-(^=) :: (a :-> b) -> b -> a -> a
-(^=) = set
-{-# INLINE (^=) #-}
-
-infixr 4 ^$=
--- | functional modify
-(^$=) :: (a :-> b) -> (b -> b) -> a -> a
-(^$=) = modify
-{-# INLINE (^$=) #-}
-
--- * Operator interface for monadic part (occasionally similar to Data.Lens)
-
-{-
-infixr 4 =$^:
--- | monadic modify & set & get
-(=$^:) :: MS.MonadState f m => (f :-> o) -> (o -> (a,o)) -> m a
-(=$^:) = M.modify
-{-# INLINE (=$^:) #-}
--}
-
-infixr 4 =$:
--- | monadic modify & set
-(=$:) :: MS.MonadState f m => (f :-> o) -> (o -> o) -> m ()
-(=$:) = M.modify
-{-# INLINE (=$:) #-}
-
--- | Zoom state in on substructure. This regretfully does not really work, because of MonadState fundep.
-focus :: (MS.MonadState a m, MS.MonadState b m) => (a :-> b) -> m c -> m c
-focus f m = do
-  a <- MS.get
-  (b,c) <- do {MS.put (get f a) ; c <- m ; b <- MS.get ; return (b,c)}
-  MS.put $ set f b a
-  return c
-  
-{-
- (Lens f) (StateT g) = StateT $ \a -> case f a of
-  StoreT (Identity h) b -> liftM (second h) (g b)
--}
-
--- | Alias for 'gets' avoiding conflict with MonadState
-getl :: MS.MonadState f m => (f :-> o) -> m o
-getl = M.gets
-{-# INLINE getl #-}
-
--- * Tuple
-
-fstl = L.fst
-{-# INLINE fstl #-}
-
-sndl = L.snd
-{-# INLINE sndl #-}
-
-fst3l = L.fst3
-{-# INLINE fst3l #-}
-
-snd3l = L.snd3
-{-# INLINE snd3l #-}
-
-trd3l = L.trd3
-{-# INLINE trd3l #-}
-
--- * Wrappers
-
--- | Wrapper around a Maybe with a default in case of Nothing
-isoMbWithDefault :: o -> (f :-> Maybe o) -> (f :-> o)
-isoMbWithDefault dflt f = iso (Iso (maybe dflt id) (Just)) . f
+import CHR.Data.Lens.FCLabels
 
--- | Wrapper around a Maybe with an embedded panic in case of Nothing, with a panic message
-isoMb :: String -> (f :-> Maybe o) -> (f :-> o)
-isoMb msg f = iso (Iso (panicJust msg) (Just)) . f
diff --git a/src/UHC/Util/Lookup.hs b/src/UHC/Util/Lookup.hs
new file mode 100644
--- /dev/null
+++ b/src/UHC/Util/Lookup.hs
@@ -0,0 +1,13 @@
+-------------------------------------------------------------------------------------------
+-- Abstraction of Map like datatypes providing lookup
+-------------------------------------------------------------------------------------------
+
+module UHC.Util.Lookup
+  (
+    module CHR.Data.Lookup
+  )
+  where
+
+-------------------------------------------------------------------------------------------
+import CHR.Data.Lookup
+
diff --git a/src/UHC/Util/Lookup/Stacked.hs b/src/UHC/Util/Lookup/Stacked.hs
new file mode 100644
--- /dev/null
+++ b/src/UHC/Util/Lookup/Stacked.hs
@@ -0,0 +1,12 @@
+
+-------------------------------------------------------------------------------------------
+-- | Lookups combined into stack of lookups, allowing combined lookup coupled with updates on top of stack only
+-------------------------------------------------------------------------------------------
+
+module UHC.Util.Lookup.Stacked
+  ( module CHR.Data.Lookup.Stacked
+  )
+  where
+
+import CHR.Data.Lookup.Stacked
+
diff --git a/src/UHC/Util/Pretty.hs b/src/UHC/Util/Pretty.hs
--- a/src/UHC/Util/Pretty.hs
+++ b/src/UHC/Util/Pretty.hs
@@ -1,513 +1,42 @@
-{-# LANGUAGE RankNTypes, TypeSynonymInstances #-}
 
 -------------------------------------------------------------------------
 -- Wrapper module around pretty printing
 -------------------------------------------------------------------------
 
 module UHC.Util.Pretty
-  ( -- module UU.Pretty
-    -- module UHC.Util.Chitil.Pretty
-    module UHC.Util.PrettySimple
-
-  , PP_DocL
-
-  -- * Choice combinators
-  , (>-|-<)
-  , (>-#-<)
-  
-  -- * General PP for list
-  , ppListSep, ppListSepV, ppListSepVV
-  
-  -- * Pack PP around
-  , ppCurlys
-  , ppPacked
-  , ppPackedWithStrings
-  , ppParens
-  , ppCurly
-  , ppBrackets
-  , ppVBar
-  
-  -- * Block, horizontal/vertical as required
-  , ppBlock, ppBlockH
-  , ppBlock'
-  , ppBlockWithStrings
-  , ppBlockWithStrings'
-  , ppBlockWithStringsH
-  
-  , ppParensCommasBlock
-  , ppCurlysBlock
-  , ppCurlysSemisBlock
-  , ppCurlysCommasBlock
-  , ppParensSemisBlock
-  , ppBracketsCommasBlock
-  
-  , ppParensCommasBlockH
-  , ppCurlysBlockH
-  , ppCurlysSemisBlockH
-  , ppCurlysCommasBlockH
-  , ppParensSemisBlockH
-  , ppBracketsCommasBlockH
-  
-  , ppBracketsCommasV
-  
-  -- * Vertical PP of list only
-  , ppVertically
-  
-  -- * Horizontal PP of list only
-  , ppCommas, ppCommas'
-  , ppSemis, ppSemis'
-  , ppSpaces
-  , ppCurlysCommas, ppCurlysCommas', ppCurlysCommasWith
-  , ppCurlysSemis, ppCurlysSemis'
-  , ppParensSpaces
-  , ppParensCommas, ppParensCommas'
-  , ppBracketsCommas
-  , ppBracketsCommas'
-  , ppHorizontally
-  , ppListSepFill
-
-  -- * Conditional
-  , ppMbPre, ppMbPost
-  , ppListPre, ppListPost
-
-  -- * Misc
-  , ppDots, ppMb, ppUnless, ppWhen
+  ( module CHR.Pretty
 
-  -- * Render
-  , showPP
-  
-  -- * IO
-  , hPutWidthPPLn, putWidthPPLn
-  , hPutPPLn, putPPLn
-  , hPutPPFile, putPPFile
   , putPPFPath
   )
   where
 
--- import UU.Pretty
--- import UHC.Util.Chitil.Pretty
-import           UHC.Util.PrettySimple
-import           UHC.Util.Utils
-import           UHC.Util.FPath
-import           UHC.Util.Time
-import           System.IO
-import           Data.List
-import           Data.Word
-import qualified Data.Set as Set
+import CHR.Pretty
+import UHC.Util.FPath
+import UHC.Util.Time
+import System.IO
 
--------------------------------------------------------------------------
--- PP utils for lists
--------------------------------------------------------------------------
 
-type PP_DocL = [PP_Doc]
-
--- | PP list with open, separator, and close
-ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
-ppListSep = ppListSepWith pp -- o >|< hlist (intersperse (pp s) (map pp pps)) >|< c
-{-
-ppListSep o c s pps
-  = o >|< l pps >|< c
-  where l []      = empty
-        l [p]     = pp p
-        l (p:ps)  = pp p >|< map (s >|<) ps
--}
-
--- | PP list with open, separator, and close, and explicit PP function
-ppListSepWith :: (PP s, PP c, PP o) => (a->PP_Doc) -> o -> c -> s -> [a] -> PP_Doc
-ppListSepWith ppa o c s pps = o >|< hlist (intersperse (pp s) (map ppa pps)) >|< c
-
-{-# DEPRECATED ppListSepFill "Use ppListSep" #-}
-ppListSepFill :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
-ppListSepFill o c s pps
-  = l pps
-  where l []      = o >|< c
-        l [p]     = o >|< pp p >|< c
-        l (p:ps)  = hlist ((o >|< pp p) : map (s >|<) ps) >|< c
-
--- | PP in a blocklike fashion, possibly on a single horizontal line if indicated, yielding the lines of the block
-ppBlock'' :: (PP ocs, PP a) => Bool -> ocs -> ocs -> ocs -> ocs -> [a] -> [PP_Doc]
-ppBlock'' _    osngl _ c _ []                   = [osngl >|< c]
-ppBlock'' _    osngl o c _ [a] | isSingleLine x = [osngl >|< x >|< c]
-                               | otherwise      = [o >|< x] ++ [pp c]
-                               where x = pp a
-ppBlock'' hori osngl o c s aa@(a:as)               -- = [o >|< a] ++ map (s >|<) as ++ [pp c]
-                               | hori && all isSingleLine xx = [osngl >|< x >|< hlist (map (s >|<) xs) >|< c]
-                               | otherwise                   = [o >|< x] ++ map (s >|<) xs ++ [pp c]
-                               where xx@(x:xs) = map pp aa
-
--- | PP in a blocklike fashion, vertically
-ppBlock' :: (PP ocs, PP a) => ocs -> ocs -> ocs -> ocs -> [a] -> [PP_Doc]
-ppBlock' = ppBlock'' False
-{-# INLINE ppBlock' #-}
-
--- | PP in a blocklike fashion, vertically, possibly horizontally
-ppBlockH' :: (PP ocs, PP a) => ocs -> ocs -> ocs -> ocs -> [a] -> [PP_Doc]
-ppBlockH' = ppBlock'' True
-{-# INLINE ppBlockH' #-}
-
--- | PP list with open, separator, and close in a possibly multiline block structure
-ppBlock :: (PP ocs, PP a) => ocs -> ocs -> ocs -> [a] -> PP_Doc
-ppBlock o c s = vlist . ppBlock' o o c s
-
--- | PP list with open, separator, and close in a possibly multiline block structure
-ppBlockH :: (PP ocs, PP a) => ocs -> ocs -> ocs -> [a] -> PP_Doc
-ppBlockH o c s = vlist . ppBlockH' o o c s
-
--- | See 'ppBlock', but with string delimiters aligned properly, yielding a list of elements
-ppBlockWithStrings'' :: (PP a) => Bool -> String -> String -> String -> [a] -> [PP_Doc]
-ppBlockWithStrings'' hori o c s = ppBlock'' hori o (pad o) c (pad s)
-  where l = maximum $ map length [o,s]
-        pad s = s ++ replicate (l - length s) ' '
-
--- | See 'ppBlock', but with string delimiters aligned properly, yielding a list of elements
-ppBlockWithStrings' :: (PP a) => String -> String -> String -> [a] -> [PP_Doc]
-ppBlockWithStrings' = ppBlockWithStrings'' False
-{-# INLINE ppBlockWithStrings' #-}
-
--- | See 'ppBlock', but with string delimiters aligned properly, yielding a list of elements, preferring single line horizontal placement
-ppBlockWithStringsH' :: (PP a) => String -> String -> String -> [a] -> [PP_Doc]
-ppBlockWithStringsH' = ppBlockWithStrings'' True
-{-# INLINE ppBlockWithStringsH' #-}
-
--- | See 'ppBlock', but with string delimiters aligned properly
-ppBlockWithStrings :: (PP a) => String -> String -> String -> [a] -> PP_Doc
-ppBlockWithStrings o c s = vlist . ppBlockWithStrings' o c s
-
--- | See 'ppBlock', but with string delimiters aligned properly, preferring single line horizontal placement
-ppBlockWithStringsH :: (PP a) => String -> String -> String -> [a] -> PP_Doc
-ppBlockWithStringsH o c s = vlist . ppBlockWithStringsH' o c s
-
--- | PP horizontally: list separated by comma
-ppCommas :: PP a => [a] -> PP_Doc
-ppCommas = ppListSep "" "" ","
-
--- | PP horizontally: list separated by comma + single blank
-ppCommas' :: PP a => [a] -> PP_Doc
-ppCommas' = ppListSep "" "" ", "
-
--- | PP horizontally: list separated by semicolon
-ppSemis :: PP a => [a] -> PP_Doc
-ppSemis = ppListSep "" "" ";"
-
--- | PP horizontally: list separated by semicolon + single blank
-ppSemis' :: PP a => [a] -> PP_Doc
-ppSemis' = ppListSep "" "" "; "
-
--- | PP horizontally: list separated by single blank
-ppSpaces :: PP a => [a] -> PP_Doc
-ppSpaces = ppListSep "" "" " "
-
--- | PP horizontally or vertically with "{", " ", and "}" in a possibly multiline block structure
-ppCurlysBlock :: PP a => [a] -> PP_Doc
-ppCurlysBlock = ppBlockWithStrings "{" "}" "  "
-{-# INLINE ppCurlysBlock #-}
-
--- | PP horizontally or vertically with "{", " ", and "}" in a possibly multiline block structure, preferring single line horizontal placement
-ppCurlysBlockH :: PP a => [a] -> PP_Doc
-ppCurlysBlockH = ppBlockWithStringsH "{" "}" "  "
-{-# INLINE ppCurlysBlockH #-}
-
--- | PP horizontally or vertically with "{", ";", and "}" in a possibly multiline block structure
-ppCurlysSemisBlock :: PP a => [a] -> PP_Doc
-ppCurlysSemisBlock = ppBlockWithStrings "{" "}" "; "
-{-# INLINE ppCurlysSemisBlock #-}
-
--- | PP horizontally or vertically with "{", ";", and "}" in a possibly multiline block structure, preferring single line horizontal placement
-ppCurlysSemisBlockH :: PP a => [a] -> PP_Doc
-ppCurlysSemisBlockH = ppBlockWithStringsH "{" "}" "; "
-{-# INLINE ppCurlysSemisBlockH #-}
-
--- | PP horizontally or vertically with "{", ",", and "}" in a possibly multiline block structure
-ppCurlysCommasBlock :: PP a => [a] -> PP_Doc
-ppCurlysCommasBlock = ppBlockWithStrings "{" "}" ", "
-{-# INLINE ppCurlysCommasBlock #-}
-
--- | PP horizontally or vertically with "{", ",", and "}" in a possibly multiline block structure, preferring single line horizontal placement
-ppCurlysCommasBlockH :: PP a => [a] -> PP_Doc
-ppCurlysCommasBlockH = ppBlockWithStringsH "{" "}" ", "
-{-# INLINE ppCurlysCommasBlockH #-}
-
--- | PP horizontally or vertically with "(", ";", and ")" in a possibly multiline block structure
-ppParensSemisBlock :: PP a => [a] -> PP_Doc
-ppParensSemisBlock = ppBlockWithStrings "(" ")" "; "
-{-# INLINE ppParensSemisBlock #-}
-
--- | PP horizontally or vertically with "(", ";", and ")" in a possibly multiline block structure, preferring single line horizontal placement
-ppParensSemisBlockH :: PP a => [a] -> PP_Doc
-ppParensSemisBlockH = ppBlockWithStringsH "(" ")" "; "
-{-# INLINE ppParensSemisBlockH #-}
-
--- | PP horizontally or vertically with "(", ",", and ")" in a possibly multiline block structure
-ppParensCommasBlock :: PP a => [a] -> PP_Doc
-ppParensCommasBlock = ppBlockWithStrings "(" ")" ", "
-{-# INLINE ppParensCommasBlock #-}
-
--- | PP horizontally or vertically with "(", ",", and ")" in a possibly multiline block structure, preferring single line horizontal placement
-ppParensCommasBlockH :: PP a => [a] -> PP_Doc
-ppParensCommasBlockH = ppBlockWithStringsH "(" ")" ", "
-{-# INLINE ppParensCommasBlockH #-}
-
--- | PP horizontally or vertically with "[", ",", and "]" in a possibly multiline block structure
-ppBracketsCommasV, ppBracketsCommasBlock, ppBracketsCommasBlockH :: PP a => [a] -> PP_Doc
-ppBracketsCommasBlock = ppBlockWithStrings "[" "]" ", "
-{-# INLINE ppBracketsCommasBlock #-}
-ppBracketsCommasBlockH = ppBlockWithStringsH "[" "]" ", "
-{-# INLINE ppBracketsCommasBlockH #-}
-ppBracketsCommasV = ppBracketsCommasBlock
-{-# DEPRECATED ppBracketsCommasV "Use ppBracketsCommasBlock" #-}
-
--- | PP horizontally with "[", ",", and "]"
-ppBracketsCommas :: PP a => [a] -> PP_Doc
-ppBracketsCommas = ppListSep "[" "]" ","
-
--- | PP horizontally with "[", ", ", and "]"
-ppBracketsCommas' :: PP a => [a] -> PP_Doc
-ppBracketsCommas' = ppListSep "[" "]" ", "
-
--- | PP horizontally with "(", " ", and ")"
-ppParensSpaces :: PP a => [a] -> PP_Doc
-ppParensSpaces = ppListSep "(" ")" " "
-
--- | PP horizontally with "(", ",", and ")"
-ppParensCommas :: PP a => [a] -> PP_Doc
-ppParensCommas = ppListSep "(" ")" ","
-
--- | PP horizontally with "(", ", ", and ")"
-ppParensCommas' :: PP a => [a] -> PP_Doc
-ppParensCommas' = ppListSep "(" ")" ", "
-
--- | PP horizontally with "{", ",", and "}"
-ppCurlysCommas :: PP a => [a] -> PP_Doc
-ppCurlysCommas = ppListSep "{" "}" ","
-
-ppCurlysCommasWith :: PP a => (a->PP_Doc) -> [a] -> PP_Doc
-ppCurlysCommasWith ppa = ppListSepWith ppa "{" "}" ","
-
--- | PP horizontally with "{", ", ", and "}"
-ppCurlysCommas' :: PP a => [a] -> PP_Doc
-ppCurlysCommas' = ppListSep "{" "}" ", "
-
--- | PP horizontally with "{", ";", and "}"
-ppCurlysSemis :: PP a => [a] -> PP_Doc
-ppCurlysSemis = ppListSep "{" "}" ";"
-
--- | PP horizontally with "{", "; ", and "}"
-ppCurlysSemis' :: PP a => [a] -> PP_Doc
-ppCurlysSemis' = ppListSep "{" "}" "; "
-
-{-
-ppCommaListV :: PP a => [a] -> PP_Doc
-ppCommaListV = ppListSepVV "[" "]" "; "
--}
-
-{-# DEPRECATED ppListSepV', ppListSepV, ppListSepVV "Use pp...Block variants" #-}
-ppListSepV' :: (PP s, PP c, PP o, PP a) => (forall x y . (PP x, PP y) => x -> y -> PP_Doc) -> o -> c -> s -> [a] -> PP_Doc
-ppListSepV' aside o c s pps
-  = l pps
-  where l []      = o `aside` c
-        l [p]     = o `aside` p `aside` c
-        l (p:ps)  = vlist ([o `aside` p] ++ map (s `aside`) (init ps) ++ [s `aside` last ps `aside` c])
-
--- compact vertical list
-{-
-ppListSepV3 :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
-ppListSepV3 o c s pps
-  = l pps
-  where l []      = o >|< c
-        l [p]     = o >|< p >|< c
-        l (p:ps)  = vlist ([o >|< p] ++ map (s >|<) (init ps) ++ [s >|< last ps >|< c])
--}
-
-ppListSepV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
-ppListSepV = ppListSepV' (>|<)
-
-ppListSepVV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
-ppListSepVV = ppListSepV' (>-<)
-
--- | Alias for 'vlist'
-ppVertically :: [PP_Doc] -> PP_Doc
-ppVertically = vlist
-
--- | Alias for 'hlist'
-ppHorizontally :: [PP_Doc] -> PP_Doc
-ppHorizontally = hlist
-
 -------------------------------------------------------------------------
--- Printing open/close pairs
--------------------------------------------------------------------------
-
-ppPacked :: (PP o, PP c, PP p) => o -> c -> p -> PP_Doc
-ppPacked o c pp
-  = o >|< pp >|< c
-
-ppPackedWithStrings :: (PP p) => String -> String -> p -> PP_Doc
-ppPackedWithStrings o c x = ppBlockWithStrings o c "" [x]
-
-ppParens, ppBrackets, ppCurly, ppCurlys, ppVBar :: PP p => p -> PP_Doc
-ppParens   = ppPackedWithStrings "(" ")"
-ppBrackets = ppPackedWithStrings "[" "]"
-ppCurly    = ppPackedWithStrings "{" "}"
-ppCurlys   = ppCurly
-ppVBar     = ppPackedWithStrings "|" "|"
-
--------------------------------------------------------------------------
--- Additional choice combinators, use with care...
--------------------------------------------------------------------------
-
-infixr 2 >-|-<, >-#-<
-
-aside :: (PP a, PP b) => String -> a -> b -> PP_Doc
-aside sep l r | isSingleLine l' && isSingleLine r' = l' >|< sep >|< r'
-              | otherwise                          = l' >-< sep >|< r'
-  where l' = pp l
-        r' = pp r
-
--- | As (>|<), but doing (>-<) when does not fit on single line
-(>-|-<) :: (PP a, PP b) => a -> b -> PP_Doc
-(>-|-<) = aside ""
-
--- | As (>#<), but doing (>-<) when does not fit on single line
-(>-#-<) :: (PP a, PP b) => a -> b -> PP_Doc
-(>-#-<) = aside " "
-
--------------------------------------------------------------------------
--- Conditional
--------------------------------------------------------------------------
-
--- | Only prefix with a 'Maybe' and extra space when 'Just'
-ppMbPre :: (PP x, PP r) => (a -> x) -> Maybe a -> r -> PP_Doc
-ppMbPre  p = maybe pp (\v rest -> p v >#< rest)
-
--- | Only suffix with a 'Maybe' and extra space when 'Just'
-ppMbPost :: (PP x, PP r) => (a -> x) -> Maybe a -> r -> PP_Doc
-ppMbPost p = maybe pp (\v rest -> rest >#< p v)
-
--- | Only prefix with a list and extra space when non-empty
-ppListPre :: (PP x, PP r) => ([a] -> x) -> [a] -> r -> PP_Doc
-ppListPre p = maybeNull pp (\l rest -> p l >#< rest)
-
--- | Only suffix with a list and extra space when non-empty
-ppListPost :: (PP x, PP r) => ([a] -> x) -> [a] -> r -> PP_Doc
-ppListPost p = maybeNull pp (\l rest -> p l >#< rest)
-
--- | Guard around PP: if False pass through
-ppUnless :: PP x => Bool -> x -> PP_Doc
-ppUnless b x = if b then empty else pp x
-
--- | Guard around PP: if True pass through
-ppWhen :: PP x => Bool -> x -> PP_Doc
-ppWhen b x = if b then pp x else empty
-
--------------------------------------------------------------------------
--- Misc
--------------------------------------------------------------------------
-
-ppDots :: PP a => [a] -> PP_Doc
-ppDots = ppListSep "" "" "."
-
-ppMb :: PP a => Maybe a -> PP_Doc
-ppMb = maybe empty pp
-
--------------------------------------------------------------------------
 -- Instances
 -------------------------------------------------------------------------
 
-instance {-# OVERLAPPABLE #-} PP a => PP (Maybe a) where
-  pp = maybe (pp "?") pp
 
-instance {-# OVERLAPPABLE #-} PP a => PP (Set.Set a) where
-  pp = ppCurlysCommasBlockH . Set.toList
-
-instance PP Bool where
-  pp = pp . show
-
-instance PP Word32 where
-  pp = pp . show
-
-instance PP ClockTime where
-  pp = pp . show
-
 instance PP FPath where
   pp = pp . fpathToStr
 
-instance PP () where
-  pp _ = pp "()"
 
-instance (PP a, PP b) => PP (a,b) where
-  pp (a,b) = "(" >|< a >-|-< "," >|< b >-|-< ")"
-
-instance (PP a, PP b, PP c) => PP (a,b,c) where
-  pp (a,b,c) = "(" >|< a >-|-< "," >|< b >-|-< "," >|< c >-|-< ")"
-
-{-
-instance (PP a, PP b, PP c, PP d) => PP (a,b,c,d) where
-  pp (a,b,c,d) = ppParensCommasBlock [a,b,c,d]
-
-instance (PP a, PP b, PP c, PP d, PP e) => PP (a,b,c,d,e) where
-  pp (a,b,c,d,e) = ppParensCommasBlock [a,b,c,d,e]
-
-instance (PP a, PP b, PP c, PP d, PP e, PP f) => PP (a,b,c,d,e,f) where
-  pp (a,b,c,d,e,f) = ppParensCommasBlock [a,b,c,d,e,f]
-
-instance (PP a, PP b, PP c, PP d, PP e, PP f, PP g) => PP (a,b,c,d,e,f,g) where
-  pp (a,b,c,d,e,f,g) = ppParensCommasBlock [a,b,c,d,e,f,g]
-
-instance (PP a, PP b, PP c, PP d, PP e, PP f, PP g, PP h) => PP (a,b,c,d,e,f,g,h) where
-  pp (a,b,c,d,e,f,g,h) = ppParensCommasBlock [a,b,c,d,e,f,g,h]
-
-instance (PP a, PP b, PP c, PP d, PP e, PP f, PP g, PP h, PP i) => PP (a,b,c,d,e,f,g,h,i) where
-  pp (a,b,c,d,e,f,g,h,i) = ppParensCommasBlock [a,b,c,d,e,f,g,h,i]
-
-instance (PP a, PP b, PP c, PP d, PP e, PP f, PP g, PP h, PP i, PP j) => PP (a,b,c,d,e,f,g,h,i,j) where
-  pp (a,b,c,d,e,f,g,h,i,j) = ppParensCommasBlock [a,b,c,d,e,f,g,h,i,j]
--}
-
--------------------------------------------------------------------------
--- Render
--------------------------------------------------------------------------
-
-showPP :: PP a => a -> String
-showPP x = disp (pp x) 1000 ""
+instance PP ClockTime where
+  pp = pp . show
 
 -------------------------------------------------------------------------
 -- PP printing to file
 -------------------------------------------------------------------------
 
-hPutLn :: Handle -> Int -> PP_Doc -> IO ()
-{-
-hPutLn h w pp
-  = do hPut h pp w
-       hPutStrLn h ""
--}
-hPutLn h w pp
-  = hPutStrLn h (disp pp w "")
 
-hPutWidthPPLn :: Handle -> Int -> PP_Doc -> IO ()
-hPutWidthPPLn h w pp = hPutLn h w pp
 
-putWidthPPLn :: Int -> PP_Doc -> IO ()
-putWidthPPLn = hPutWidthPPLn stdout
-
-hPutPPLn :: Handle -> PP_Doc -> IO ()
-hPutPPLn h = hPutWidthPPLn h 4000
-
-putPPLn :: PP_Doc -> IO ()
-putPPLn = hPutPPLn stdout
-
-hPutPPFile :: Handle -> PP_Doc -> Int -> IO ()
-hPutPPFile h pp wid
-  = hPutLn h wid pp
-
-
 putPPFPath :: FPath -> PP_Doc -> Int -> IO ()
 putPPFPath fp pp wid
   = do { fpathEnsureExists fp
        ; putPPFile (fpathToStr fp) pp wid
        }
 
-putPPFile :: String -> PP_Doc -> Int -> IO ()
-putPPFile fn pp wid
-  =  do  {  h <- openFile fn WriteMode
-         ;  hPutPPFile h pp wid
-         ;  hClose h
-         }
diff --git a/src/UHC/Util/PrettySimple.hs b/src/UHC/Util/PrettySimple.hs
deleted file mode 100644
--- a/src/UHC/Util/PrettySimple.hs
+++ /dev/null
@@ -1,230 +0,0 @@
-{-# LANGUAGE TypeSynonymInstances #-}
-
--------------------------------------------------------------------------
--- Subset of UU.Pretty, based on very simple pretty printing
--------------------------------------------------------------------------
-
-module UHC.Util.PrettySimple
-  ( PP_Doc, PP(..)
-  , disp
-  , hPut
-  , Doc(..)
-
-  , (>|<), (>-<)
-  , (>#<)
-  , hlist, hlistReverse, vlist, hv
-  , fill
-  , indent
-
-{-
-  , pp_wrap, pp_quotes, pp_doubleQuotes, pp_parens, pp_brackets, pp_braces
-  , ppPacked, ppParens, ppBrackets, ppBraces, ppCurlys
--}
-
-  , empty, text
-  
-  -- * Internal use only
-  , isSingleLine
-  )
-  where
-
-import System.IO
--- import Data.Data
-import Data.Typeable
-
--------------------------------------------------------------------------
--- Doc structure
--------------------------------------------------------------------------
-
--- | Cached info about combi of sub Docs
-data Cached = Cached
-    { cchEmp :: !Bool       -- ^ is it empty
-    , cchSng :: !Bool       -- ^ is it a single line
-    }
-  deriving (Typeable)
-
--- | Doc structure
-data Doc
-  = Emp
-  | Str         !String                 -- basic string
-  | Hor         !Cached !Doc  !Doc      -- horizontal positioning
-  | Ver         !Cached !Doc  !Doc      -- vertical positioning
-  | Ind         !Int !Doc               -- indent
-  deriving (Typeable)
-
-type PP_Doc = Doc
-
--------------------------------------------------------------------------
--- Basic combinators
--------------------------------------------------------------------------
-
-infixr 3 >|<, >#<
-infixr 2 >-<
-
-cached :: (PP a, PP b) => (PP_Doc -> PP_Doc -> Cached) -> (Cached -> PP_Doc -> PP_Doc -> PP_Doc) -> a -> b -> PP_Doc
-cached cchd mk l r = mk (cchd l' r') l' r'
-  where l' = pp l
-        r' = pp r
-
--- | PP horizontally aside
-(>|<) :: (PP a, PP b) => a -> b -> PP_Doc
-l >|< r = cached mkcch Hor l r -- pp l `Hor` pp r
-  where mkcch l r = Cached emp sng
-          where emp = isEmpty l && isEmpty r
-                sng = isSingleLine l && isSingleLine r
-
--- | PP vertically above
-(>-<) :: (PP a, PP b) => a -> b -> PP_Doc
-l >-< r = cached mkcch Ver l r -- pp l `Ver` pp r   -- pp l <$$> pp r
-  where mkcch l r = Cached (empl && empr) sng
-          where empl = isEmpty l
-                empr = isEmpty r
-                sng  = empl && isSingleLine r || empr && isSingleLine l
-
--- | PP horizontally aside with 1 blank in between
-(>#<) :: (PP a, PP b) => a -> b -> PP_Doc
-l >#< r  =  l >|< " " >|< r
-
--- | Indent
-indent :: PP a => Int -> a -> PP_Doc
-indent i d = Ind i $ pp d
-{-# INLINE indent #-}
-
--- | basic string
-text :: String -> PP_Doc
-text = Str
-{-# INLINE text #-}
-
--- | empty PP
-empty :: PP_Doc
-empty = Emp
-{-# INLINE empty #-}
-
--------------------------------------------------------------------------
--- Derived combinators
--------------------------------------------------------------------------
-
-vlist, hlist, hlistReverse :: PP a => [a] -> PP_Doc
--- | PP list horizontally
-vlist [] = empty
-vlist as = foldr  (>-<) empty as
-
--- | PP list vertically
-hlist [] = empty
-hlist as = foldr  (>|<) empty as
-
--- | PP list vertically reverse
-hlistReverse [] = empty
-hlistReverse as = foldr (flip (>|<)) empty as
-
--- | PP list vertically, alias for 'vlist'
-hv :: PP a => [a] -> PP_Doc
-hv = vlist
-
--- | PP list horizontally, alias for 'hlist'
-fill :: PP a => [a] -> PP_Doc
-fill = hlist
-
--------------------------------------------------------------------------
--- PP class
--------------------------------------------------------------------------
-
--- | Interface for PP
-class Show a => PP a where
-  pp     :: a   -> PP_Doc
-  pp       = text . show
-
-  ppList :: [a] -> PP_Doc
-  ppList as = hlist as
-
-instance PP PP_Doc where
-  pp     = id
-
-instance PP Char where
-  pp c   = text [c]
-  ppList = text
-
-instance PP a => PP [a] where
-  pp = ppList
-
-instance Show PP_Doc where
-  show p = disp p 200 ""
-
-instance PP Int where
-  pp = text . show
-
-instance PP Integer where
-  pp = text . show
-
-instance PP Float where
-  pp = text . show
-
--------------------------------------------------------------------------
--- Observation
--------------------------------------------------------------------------
-
--- | Is empty doc?
-isEmpty :: PP_Doc -> Bool
-isEmpty Emp           = True
-isEmpty (Ver c d1 d2) = cchEmp c
-isEmpty (Hor c d1 d2) = cchEmp c
-isEmpty (Ind _  d   ) = isEmpty d
-isEmpty (Str _      ) = False
-
--- | Is single line doc?
-isSingleLine :: PP_Doc -> Bool
-isSingleLine Emp           = True
-isSingleLine (Ver c d1 d2) = cchSng c
-isSingleLine (Hor c d1 d2) = cchSng c
-isSingleLine (Ind _  d   ) = isSingleLine d
-isSingleLine (Str _      ) = True
-
--------------------------------------------------------------------------
--- Rendering
--------------------------------------------------------------------------
-
--- | Display to string
-disp  ::  PP_Doc -> Int -> ShowS
-disp d _ s
-  = r
-  where (r,_) = put 0 d s
-        put p d s
-          = case d of
-              Emp              -> (s,p)
-              Str s'           -> (s' ++ s,p + length s')
-              Ind i  d         -> (ind ++ r,p')
-                               where (r,p') = put (p+i) d s
-                                     ind = replicate i ' '
-              Hor _ d1 d2      -> (r1,p2)
-                               where (r1,p1) = put p  d1 r2
-                                     (r2,p2) = put p1 d2 s
-              Ver _ d1 d2 | isEmpty d1
-                               -> put p d2 s
-              Ver _ d1 d2 | isEmpty d2
-                               -> put p d1 s
-              Ver _ d1 d2        -> (r1,p2)
-                               where (r1,p1) = put p d1 $ "\n" ++ ind ++ r2
-                                     (r2,p2) = put p d2 s
-                                     ind = replicate p ' '
-
--- | Display to Handle
-hPut  :: Handle -> PP_Doc -> Int -> IO ()
-hPut h d _
-  = do _ <- put 0 d h
-       return ()
-  where put p d h
-          = case d of
-              Emp              -> return p
-              Str s            -> do hPutStr h s
-                                     return $ p + length s
-              Ind i  d         -> do hPutStr h $ replicate i ' '
-                                     put (p+i) d h
-              Hor _ d1 d2      -> do p' <- put p d1 h
-                                     put p' d2 h
-              Ver _ d1 d2 | isEmpty d1
-                               -> put p d2 h
-              Ver _ d1 d2 | isEmpty d2
-                               -> put p d1 h
-              Ver _ d1 d2      -> do _ <- put p d1 h
-                                     hPutStr h $ "\n" ++ replicate p ' '
-                                     put p d2 h
diff --git a/src/UHC/Util/ScopeVarMp.hs b/src/UHC/Util/ScopeVarMp.hs
--- a/src/UHC/Util/ScopeVarMp.hs
+++ b/src/UHC/Util/ScopeVarMp.hs
@@ -273,8 +273,8 @@
   {-# INLINE varlookupSingletonWithMetaLev #-}
 
 
-instance Ord k => VarLookupCmb (VarMp' k v) (VarMp' k v) where
-  m1 |+> m2 = varmpUnionWith const m1 m2
+instance Ord k => LookupApply (VarMp' k v) (VarMp' k v) where
+  m1 `apply` m2 = varmpUnionWith const m1 m2
 
 {-
 instToL1VarMp :: [InstTo] -> VarMp
diff --git a/src/UHC/Util/Serialize.hs b/src/UHC/Util/Serialize.hs
--- a/src/UHC/Util/Serialize.hs
+++ b/src/UHC/Util/Serialize.hs
@@ -99,7 +99,7 @@
 import           System.IO (openBinaryFile)
 import           UHC.Util.Utils
 import           Data.Typeable
-import           Data.Typeable.Internal
+-- import           Data.Typeable.Internal
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
@@ -381,6 +381,7 @@
   sput = sputPlain
   sget = sgetPlain
 
+{- FIXME? TypeRep changed, this does not work anymore...
 instance Serialize TyCon where
   sput tc = sput (tyConPackage tc) >> sput (tyConModule tc) >> sput (tyConName tc)
   sget = liftM3 mkTyCon3 sget sget sget
@@ -389,7 +390,9 @@
   sput tr = sput tc >> sput ka >> sput ta
     where (tc,ka,ta) = splitPolyTyConApp tr
   sget = liftM3 mkPolyTyConApp sget sget sget
-
+-}  
+  
+  
 {-
 instance Serialize String where
   sput = sputShared
diff --git a/src/UHC/Util/Substitutable.hs b/src/UHC/Util/Substitutable.hs
--- a/src/UHC/Util/Substitutable.hs
+++ b/src/UHC/Util/Substitutable.hs
@@ -2,92 +2,9 @@
 --- Substitution abilities
 -------------------------------------------------------------------------------------------
 
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}
-
 module UHC.Util.Substitutable
-  (
-    VarUpdatable(..)
-  , VarExtractable(..)
-  
-  , ExtrValVarKey
-  
-  , VarTerm(..)
+  ( module CHR.Data.Substitutable
   )
   where
 
-import qualified Data.Set as Set
-import           UHC.Util.VarMp
-
--------------------------------------------------------------------------------------------
---- Misc
--------------------------------------------------------------------------------------------
-
-infixr 6 `varUpd`
-infixr 6 `varUpdCyc`
-
--- | The variable wich is used as a key into a substitution
-type family ExtrValVarKey vv :: *
-
--------------------------------------------------------------------------------------------
---- Updatable
--------------------------------------------------------------------------------------------
-
--- | Term in which variables can be updated with a subst(itution)
-class VarUpdatable vv subst where
-  -- | Update
-  varUpd            ::  subst -> vv -> vv
-  -- s `varUpd` x = let (x',_) = s `varUpdCyc` x in x
-  -- {-# INLINE varUpd #-}
-
-  -- | Update with cycle detection
-  varUpdCyc         ::  subst -> vv -> (vv, VarMp' (VarLookupKey subst) (VarLookupVal subst))
-  s `varUpdCyc` x = (s `varUpd` x, emptyVarMp)
-  {-# INLINE varUpdCyc #-}
-
-instance {-# OVERLAPPABLE #-} VarUpdatable vv subst => VarUpdatable (Maybe vv) subst where
-  s `varUpd`    m = fmap (s `varUpd`) m
-
-  s `varUpdCyc` (Just x) = let (x',cm) = s `varUpdCyc` x in (Just x', cm)
-  s `varUpdCyc` Nothing  = (Nothing, emptyVarMp)
-
-instance {-# OVERLAPPABLE #-} (Ord (VarLookupKey subst), VarUpdatable vv subst) => VarUpdatable [vv] subst where
-  s `varUpd`    l = map (s `varUpd`) l
-  s `varUpdCyc` l = let (l',cms) = unzip $ map (s `varUpdCyc`) l in (l', varmpUnions cms)
-
--------------------------------------------------------------------------------------------
---- Extractibility of free vars
--------------------------------------------------------------------------------------------
-
--- | Term from which free variables can be extracted
-class Ord (ExtrValVarKey vv) => VarExtractable vv where
-  -- | Free vars, as a list
-  varFree           ::  vv -> [ExtrValVarKey vv]
-  varFree           =   Set.toList . varFreeSet
-  
-  -- | Free vars, as a set
-  varFreeSet        ::  vv -> Set.Set (ExtrValVarKey vv)
-  varFreeSet        =   Set.fromList . varFree
-
-type instance ExtrValVarKey (Maybe vv) = ExtrValVarKey vv
-
-instance {-# OVERLAPPABLE #-} (VarExtractable vv, Ord (ExtrValVarKey vv)) => VarExtractable (Maybe vv) where
-  varFreeSet        =   maybe Set.empty varFreeSet
-
-type instance ExtrValVarKey [vv] = ExtrValVarKey vv
-
-instance {-# OVERLAPPABLE #-} (VarExtractable vv, Ord (ExtrValVarKey vv)) => VarExtractable [vv] where
-  varFreeSet        =   Set.unions . map varFreeSet
-
--------------------------------------------------------------------------------------------
---- Is a term with a variable which we can observe and construct
--------------------------------------------------------------------------------------------
-
--- | Term with a (substitutable, extractable, free, etc.) variable
-class VarTerm vv where
-  -- | Maybe is a key
-  varTermMbKey :: vv -> Maybe (ExtrValVarKey vv)
-  -- | Construct wrapper for key (i.e. lift, embed)
-  varTermMkKey :: ExtrValVarKey vv -> vv
-  
-
-
+import CHR.Data.Substitutable
diff --git a/src/UHC/Util/TreeTrie2.hs b/src/UHC/Util/TreeTrie2.hs
deleted file mode 100644
--- a/src/UHC/Util/TreeTrie2.hs
+++ /dev/null
@@ -1,825 +0,0 @@
-{-# LANGUAGE CPP, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, MultiParamTypeClasses #-}
-
--------------------------------------------------------------------------------------------
---- TreeTrie, variation which allows matching on subtrees marked as a variable (kind of unification)
--------------------------------------------------------------------------------------------
-
-{- |
-A TreeTrie is a search structure where the key actually consists of a
-tree of keys, represented as a list of layers in the tree, 1 for every
-depth, starting at the top, which are iteratively used for searching.
-The search structure for common path/prefixes is shared, the trie
-branches to multiple corresponding to available children, length
-equality of children is used in searching (should match)
-
-The TreeTrie structure implemented in this module deviates from the
-usual TreeTrie implementations in that it allows wildcard matches
-besides the normal full match. The objective is to also be able to
-retrieve values for which (at insertion time) it has been indicated that
-part does not need full matching. This intentionally is similar to
-unification, where matching on a variable will succeed for arbitrary
-values. Unification is not the job of this TreeTrie implementation, but
-by returning partial matches as well, a list of possible match
-candidates is returned.
--}
-
-module UHC.Util.TreeTrie2
-  ( -- * Key into TreeTrie
-  {-
-    TreeTrie1Key(..)
-  , TreeTrieMp1Key(..)
-  , TreeTrieMpKey
-  , TreeTrieKey
-  
-  , TrTrKey
-  
-  , ppTreeTrieKey
-  
-  , ttkSingleton
-  , ttkAdd', ttkAdd
-  , ttkChildren
-  , ttkFixate
-  
-  , ttkParentChildren
-  
-    -- * Keyable
-  , TreeTrieKeyable(..)
-  
-    -- * TreeTrie
-  , TreeTrie
-  , emptyTreeTrie
-  , empty
-  , toListByKey, toList
-  , fromListByKeyWith, fromList
-
-    -- * Lookup
-  , TreeTrieLookup(..)
-  
-  , lookupPartialByKey
-  , lookupPartialByKey'
-  , lookupByKey
-  , lookup
-  , lookupResultToList
-
-    -- * Properties/observations
-  , isEmpty, null
-  , elems
-  
-    -- * Construction
-  , singleton, singletonKeyable
-  , unionWith, union, unionsWith, unions
-  , insertByKeyWith, insertByKey
-  
-    -- * Deletion
-  , deleteByKey, delete
-  , deleteListByKey
-  -}
-  )
-  where
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import           Data.Maybe
-import           Prelude hiding (lookup,null)
-import qualified UHC.Util.FastSeq as Seq
-import qualified Data.List as List
-import           UHC.Util.AssocL
-import           UHC.Util.Utils
-import           UHC.Util.Pretty hiding (empty)
-import qualified UHC.Util.Pretty as PP
-import           Control.Monad
-import           Data.Typeable(Typeable)
-import           GHC.Generics
-import           UHC.Util.Serialize
-
--------------------------------------------------------------------------------------------
---- Key into TreeTrie
--------------------------------------------------------------------------------------------
-
--- | Both key and trie can allow partial matching, indicated by TreeTrie1Key
-data TreeTrie1Key k
-  = TT1K_One    !k
-  | TT1K_Any                            -- used to wildcard match a single node in a tree
-  deriving (Eq, Ord, Generic)
-
--- | A key in a layer of TreeTrieMpKey
-data TreeTrieMp1Key k
-  = TTM1K       ![TreeTrie1Key k]
-  | TTM1K_Any                           -- used to wildcard match multiple children, internal only
-  deriving (Eq, Ord, Generic)
-
--- | The key into a map used internally by the trie
-newtype TreeTrieMpKey k
-  = TreeTrieMpKey {unTreeTrieMpKey :: [TreeTrieMp1Key k]}
-  deriving (Eq, Ord, Generic)
-
--- | The key used externally to index into a trie
-newtype TreeTrieKey k
-  = TreeTrieKey {unTreeTrieKey :: [TreeTrieMpKey k]}
-  deriving (Eq, Ord, Generic)
-
-#if __GLASGOW_HASKELL__ >= 708
-deriving instance Typeable  TreeTrie1Key
-deriving instance Typeable  TreeTrieMp1Key
-#else
-deriving instance Typeable1 TreeTrie1Key
-deriving instance Typeable1 TreeTrieMp1Key
-#endif
--- deriving instance Data x => Data (TreeTrie1Key x) 
--- deriving instance Data x => Data (TreeTrieMp1Key x) 
-
-instance Show k => Show (TreeTrie1Key k) where
-  show  TT1K_Any    = "*"
-  show (TT1K_One k) = "(1:" ++ show k ++ ")"
-
-instance Show k => Show (TreeTrieMp1Key k) where
-  show (TTM1K_Any )  = "**" -- ++ show i
-  show (TTM1K k)     = show k
-
-instance PP k => PP (TreeTrie1Key k) where
-  pp  TT1K_Any    = pp "*"
-  pp (TT1K_One k) = ppParens $ "1:" >|< k
-
-instance PP k => PP (TreeTrieMp1Key k) where
-  pp = ppTreeTrieMp1Key
-
-ppTreeTrieMp1Key :: PP k => TreeTrieMp1Key k -> PP_Doc
-ppTreeTrieMp1Key (TTM1K l) = ppBracketsCommas l
-ppTreeTrieMp1Key (TTM1K_Any ) = pp "**" -- >|< i
-
-ppTreeTrieMpKey :: PP k => TreeTrieMpKey k -> PP_Doc
-ppTreeTrieMpKey = ppListSep "<" ">" "," . map ppTreeTrieMp1Key . unTreeTrieMpKey
-
--- | Pretty print TrieKey
-ppTreeTrieKey :: PP k => TreeTrieKey k -> PP_Doc
-ppTreeTrieKey = ppBracketsCommas . map ppTreeTrieMpKey . unTreeTrieKey
-
-instance Show k => Show (TreeTrieMpKey k) where
-  show (TreeTrieMpKey ks) = show ks
-
-instance Show k => Show (TreeTrieKey k) where
-  show (TreeTrieKey ks) = show ks
-
-instance PP k => PP (TreeTrieMpKey k) where
-  pp = ppTreeTrieMpKey
-  {-# INLINE pp #-}
-
-instance PP k => PP (TreeTrieKey k) where
-  pp = ppTreeTrieKey
-  {-# INLINE pp #-}
-
--------------------------------------------------------------------------------------------
---- TreeTrieMpKey inductive construction from new node and children keys
--------------------------------------------------------------------------------------------
-
-
--- | Make singleton, which should at end be stripped from bottom layer of empty TTM1K []
-ttkSingleton :: TreeTrie1Key k -> TreeTrieKey k
-ttkSingleton k = TreeTrieKey $ TreeTrieMpKey [TTM1K [k]] : unTreeTrieKey ttkEmpty
-
--- | empty key
-ttkEmpty :: TreeTrieKey k
-ttkEmpty = TreeTrieKey [TreeTrieMpKey [TTM1K []]]
-
--- | Construct intermediate structure for children for a new Key
---   length ks >= 2
-ttkChildren :: [TreeTrieKey k] -> TreeTrieKey k
-ttkChildren ks
-  = TreeTrieKey $ map TreeTrieMpKey
-    $ [TTM1K $ concat [k | TTM1K k <- flatten hs]]       -- first level children are put together in singleton list of list with all children
-      : merge (split tls)                                 -- and the rest is just concatenated
-  where (hs,tls) = split ks
-        split = unzip . map ((\(h,t) -> (h, TreeTrieKey t)) . hdAndTl . unTreeTrieKey)
-        merge (hs,[]) = [flatten hs]
-        merge (hs,tls) = flatten hs : merge (split $ filter (not . List.null . unTreeTrieKey) tls)
-        flatten = concatMap (\(TreeTrieMpKey h) -> h)
-
--- | Add a new layer with single node on top, combining the rest.
-ttkAdd' :: TreeTrie1Key k -> TreeTrieKey k -> TreeTrieKey k
-ttkAdd' k (TreeTrieKey ks) = TreeTrieKey $ TreeTrieMpKey [TTM1K [k]] : ks
-
--- | Add a new layer with single node on top, combining the rest.
---   length ks >= 2
-ttkAdd :: TreeTrie1Key k -> [TreeTrieKey k] -> TreeTrieKey k
-ttkAdd k ks = ttkAdd' k (ttkChildren ks)
-
--- | Fixate by removing lowest layer empty children
-ttkFixate :: TreeTrieKey k -> TreeTrieKey k
-ttkFixate (TreeTrieKey (kk : kks))
-  | all (\(TTM1K k) -> List.null k) (unTreeTrieMpKey kk)
-              = TreeTrieKey []
-  | otherwise = TreeTrieKey $ kk : unTreeTrieKey (ttkFixate $ TreeTrieKey kks)
-ttkFixate _   = TreeTrieKey []
-
--------------------------------------------------------------------------------------------
---- TreeTrieKey deconstruction
--------------------------------------------------------------------------------------------
-
-
--- | Split key into parent and children components, inverse of ttkAdd'
-ttkParentChildren :: TreeTrieKey k -> ( TreeTrie1Key k, TreeTrieKey k )
-ttkParentChildren (TreeTrieKey k)
-  = case k of
-      (TreeTrieMpKey [TTM1K [h]] : t) -> (h, TreeTrieKey t)
-
--------------------------------------------------------------------------------------------
---- TreeTrieMpKey matching
--------------------------------------------------------------------------------------------
-
-
--- | Match 1st arg with wildcards to second, returning the to be propagated key to next layer in tree
-matchTreeTrieMpKeyTo :: Eq k => TreeTrieMpKey k -> TreeTrieMpKey k -> Maybe (TreeTrieMpKey k -> TreeTrieMpKey k)
-matchTreeTrieMpKeyTo (TreeTrieMpKey l) (TreeTrieMpKey r)
-  | all isJust llrr = Just (\(TreeTrieMpKey k) -> TreeTrieMpKey $ concat $ zipWith ($) (concatMap (fromJust) llrr) k)
-  | otherwise       = Nothing
-  where llrr = zipWith m l r
-        m (TTM1K     l) (TTM1K r) | length l == length r && all isJust lr
-                                                  = Just (concatMap fromJust lr)
-                                  | otherwise     = Nothing
-                                  where lr = zipWith m1 l r
-        m (TTM1K_Any  ) (TTM1K []) = Just []
-        m (TTM1K_Any  ) (TTM1K r ) = Just [const $ replicate (length r) TTM1K_Any]
-        m1  TT1K_Any     _                    = Just [const [TTM1K_Any]]
-        m1 (TT1K_One l) (TT1K_One r) | l == r = Just [\x -> [x]]
-        m1  _            _                    = Nothing
-
--------------------------------------------------------------------------------------------
---- Keyable
--------------------------------------------------------------------------------------------
-
-type family TrTrKey x :: *
-
--- | Keyable values, i.e. capable of yielding a TreeTrieKey for retrieval from a trie
-class TreeTrieKeyable x where
-  toTreeTrieKey :: x -> TreeTrieKey (TrTrKey x)
-
--------------------------------------------------------------------------------------------
---- TreeTrie structure
--------------------------------------------------------------------------------------------
-
--- | Child structure
-type TreeTrieChildren k v
-  = Map.Map (TreeTrieMpKey k) (TreeTrie k v)
-
--- | The trie structure, branching out on (1) kind, (2) nr of children, (3) actual key
-data TreeTrie k v
-  = TreeTrie
-      { ttrieMbVal       :: Maybe v                                                 -- value
-      , ttrieSubs        :: TreeTrieChildren k v                                    -- children
-      }
- deriving (Typeable)
-
-emptyTreeTrie, empty :: TreeTrie k v
-emptyTreeTrie = TreeTrie Nothing Map.empty
-
-empty = emptyTreeTrie
-
-instance (Show k, Show v) => Show (TreeTrie k v) where
-  showsPrec _ t = showList $ toListByKey t
-
-instance (PP k, PP v) => PP (TreeTrie k v) where
-  pp t = ppBracketsCommasBlock $ map (\(a,b) -> ppTreeTrieKey a >#< ":" >#< b) $ toListByKey t
-
-
--------------------------------------------------------------------------------------------
---- Conversion
--------------------------------------------------------------------------------------------
-
--- Reconstruction of original key-value pairs.
-
-
-toFastSeqSubs :: TreeTrieChildren k v -> Seq.FastSeq (TreeTrieKey k, v)
-toFastSeqSubs ttries
-  = Seq.unions
-      [ Seq.map (\(TreeTrieKey ks,v) -> (TreeTrieKey $ k:ks, v)) $ toFastSeq True t
-      | (k,t) <- Map.toList ttries
-      ]
-
-toFastSeq :: Bool -> TreeTrie k v -> Seq.FastSeq (TreeTrieKey k, v)
-toFastSeq inclEmpty ttrie
-  =          (case ttrieMbVal ttrie of
-                Just v | inclEmpty -> Seq.singleton (TreeTrieKey [], v)
-                _                  -> Seq.empty
-             )
-    Seq.:++: toFastSeqSubs (ttrieSubs ttrie)
-
-toListByKey, toList :: TreeTrie k v -> [(TreeTrieKey k,v)]
-toListByKey = Seq.toList . toFastSeq True
-
-toList = toListByKey
-
-fromListByKeyWith :: Ord k => (v -> v -> v) -> [(TreeTrieKey k,v)] -> TreeTrie k v
-fromListByKeyWith cmb = unionsWith cmb . map (uncurry singleton)
-
-fromListByKey :: Ord k => [(TreeTrieKey k,v)] -> TreeTrie k v
-fromListByKey = unions . map (uncurry singleton)
-
-fromListWith :: Ord k => (v -> v -> v) -> [(TreeTrieKey k,v)] -> TreeTrie k v
-fromListWith cmb = fromListByKeyWith cmb
-
-fromList :: Ord k => [(TreeTrieKey k,v)] -> TreeTrie k v
-fromList = fromListByKey
-
--------------------------------------------------------------------------------------------
---- TreeTrie lookup/insertion, how to
--------------------------------------------------------------------------------------------
-
-{-
-
--- | How to lookup in a TreeTrie
-data TreeTrieLookup
-  = TTL_Exact                           -- lookup with exact match
-  | TTL_WildInTrie                      -- lookup with wildcard matching in trie
-  | TTL_WildInKey                       -- lookup with wildcard matching in key
-  deriving (Eq)
-  
--}
-
--------------------------------------------------------------------------------------------
---- Lookup
--------------------------------------------------------------------------------------------
-
-data LookupAllMatch v
-  = LookupAllMatch
-      { lookupAllMatchWildInTrie    :: [v]
-      , lookupAllMatchExact         :: Maybe v
-      , lookupAllMatchWildInKey     :: [v]
-      }
-  deriving Show
-
-emptyLookupAllMatch = LookupAllMatch [] Nothing []
-
--- | Incorrect, under dev
-lookupAllMatch :: Ord k => TreeTrieKey k -> TreeTrie k v -> LookupAllMatch v
-lookupAllMatch (TreeTrieKey ks) ttrie
-    = l id ks ttrie
-  where
-    -- lookup
-    l updTKey ks ttrie = case ks of
-      []     -> emptyLookupAllMatch { lookupAllMatchExact = ttrieMbVal ttrie }
-      (k:ks) -> case Map.lookup k $ ttrieSubs ttrie of
-        Nothing     -> LookupAllMatch [] Nothing []
-        Just ttrie' -> case l id ks ttrie' of
-          m -> -- @(LookupAllMatch {lookupAllMatchWildInTrie=subs1, lookupAllMatchWildInKey=subs2}) ->
-              m { lookupAllMatchWildInTrie = catMaybes (map lookupAllMatchExact subs1) ++ concatMap lookupAllMatchWildInTrie subs1
-                , lookupAllMatchWildInKey  = catMaybes (map lookupAllMatchExact subs2) ++ concatMap lookupAllMatchWildInKey  subs2
-                }
-            where subs1 -- (subs,mbs)
-                    = -- unzip
-                        [ case ks of
-                            []                             -> l id [] t
-                            (_:_) | Map.null (ttrieSubs t) -> match (fromJust mbm) ks
-                                  | otherwise              -> l (fromJust mbm) ks t
-                               where match m (km:kms)
-                                       = case matchTreeTrieMpKeyTo kt' km of
-                                           Just m -> match m kms
-                                           _      -> emptyLookupAllMatch
-                                       where kt' = m $ TreeTrieMpKey $ repeat (TTM1K [])
-                                     match _ []
-                                       = l id [] t
-                        | (kt,t) <- Map.toList $ ttrieSubs ttrie
-                        , let kt' = updTKey kt
-                              mbm = matchTreeTrieMpKeyTo kt' k
-                        , isJust mbm
-                        ]
-                  subs2 -- (subs,mbs)
-                    = -- unzip
-                        [ case ks of
-                            (ksk:ksks)                  -> l id (fromJust m ksk : ksks) t
-                            [] | Map.null (ttrieSubs t) -> l id  [] t
-                               | otherwise              -> l id ([fromJust m $ TreeTrieMpKey $ repeat (TTM1K [])]) t
-                        | (kt,t) <- Map.toList $ ttrieSubs ttrie
-                        , let m = matchTreeTrieMpKeyTo k kt
-                        , isJust m
-                        ]
-{-
-    -- lookup
-    l updTKey ks ttrie = case ks of
-      []     -> dflt ttrie
-      (k:ks) -> case Map.lookup k $ ttrieSubs ttrie of
-        Nothing     -> LookupAllMatch [] Nothing []
-        Just ttrie' -> case l id ks ttrie' of
-          m -> -- @(LookupAllMatch {lookupAllMatchWildInTrie=subs1, lookupAllMatchWildInKey=subs2}) ->
-              m { lookupAllMatchWildInTrie = catMaybes (map lookupAllMatchExact subs1) ++ concatMap lookupAllMatchWildInTrie subs1
-                , lookupAllMatchWildInKey  = catMaybes (map lookupAllMatchExact subs2) ++ concatMap lookupAllMatchWildInKey  subs2
-                }
-            where subs1 -- (subs,mbs)
-                    = -- unzip
-                        [ case ks of
-                            []                             -> l id [] t
-                            (_:_) | Map.null (ttrieSubs t) -> match (fromJust mbm) ks
-                                  | otherwise              -> l (fromJust mbm) ks t
-                               where match m (km:kms)
-                                       = case matchTreeTrieMpKeyTo kt' km of
-                                           Just m -> match m kms
-                                           _      -> emptyLookupAllMatch
-                                       where kt' = m $ TreeTrieMpKey $ repeat (TTM1K [])
-                                     match _ []
-                                       = l id [] t
-                        | (kt,t) <- Map.toList $ ttrieSubs ttrie
-                        , let kt' = updTKey kt
-                              mbm = matchTreeTrieMpKeyTo kt' k
-                        , isJust mbm
-                        ]
-                  subs2 -- (subs,mbs)
-                    = -- unzip
-                        [ case ks of
-                            (ksk:ksks)                  -> l id (fromJust m ksk : ksks) t
-                            [] | Map.null (ttrieSubs t) -> l id  [] t
-                               | otherwise              -> l id ([fromJust m $ TreeTrieMpKey $ repeat (TTM1K [])]) t
-                        | (kt,t) <- Map.toList $ ttrieSubs ttrie
-                        , let m = matchTreeTrieMpKeyTo k kt
-                        , isJust m
-                        ]
-
-    -- default return
-    dflt ttrie = emptyLookupAllMatch { lookupAllMatchExact = ttrieMbVal ttrie }
--}
-{-
-
--- | Normal lookup for exact match + partial matches (which require some sort of further unification, determining whether it was found)
-lookupPartialByKey' :: forall k v v' . (PP k,Ord k) => (TreeTrieKey k -> v -> v') -> TreeTrieLookup -> TreeTrieKey k -> TreeTrie k v -> ([v'],Maybe v')
-lookupPartialByKey' mkRes ttrieLookup keys ttrie
-  = l id mkRes keys ttrie
-  where l :: (TreeTrieMpKey k -> TreeTrieMpKey k) -> (TreeTrieKey k -> v -> v') -> TreeTrieKey k -> TreeTrie k v -> ([v'],Maybe v')
-        l = case ttrieLookup of
-              -- Exact match
-              TTL_Exact -> \_ mkRes (TreeTrieMpKey keys) ttrie ->
-                case keys of
-                  [] -> dflt mkRes ttrie
-                  (k : ks)
-                     -> case Map.lookup k $ ttrieSubs ttrie of
-                          Just ttrie'
-                            -> ([], m)
-                            where (_,m) = l id (res mkRes k) (TreeTrieMpKey ks) ttrie'
-                          _ -> ([], Nothing)
-              
-              -- Match with possible wildcard in Trie
-              TTL_WildInTrie -> \updTKey mkRes (TreeTrieMpKey keys) ttrie ->
-                -- tr "TTL_WildInTrie" (ppTreeTrieKey keys >#< (ppTreeTrieMpKey $ updTKey $ replicate (5) (TTM1K []))) $
-                case keys of
-                  [] -> dflt mkRes ttrie
-                  (k : ks)
-                     -> (catMaybes mbs ++ concat subs, Nothing)
-                     where (subs,mbs)
-                             = unzip
-                                 [ case ks of
-                                     []                                  -> l id (res mkRes k) [] t
-                                     (ksk:ksks) | Map.null (ttrieSubs t) -> match (res mkRes k) (fromJust mbm) ks
-                                                | otherwise              -> l (fromJust mbm) (res mkRes k) ks t
-                                        where match mkRes m (km:kms)
-                                                = case matchTreeTrieMpKeyTo kt' km of
-                                                    Just m -> match (res mkRes k) m kms
-                                                    _      -> ([], Nothing)
-                                                where kt' = m $ repeat (TTM1K [])
-                                              match mkRes _ []
-                                                = l id (res mkRes k) [] t
-                                 | (kt,t) <- Map.toList $ ttrieSubs ttrie
-                                 , let kt' = updTKey kt
-                                       mbm = -- (\v -> tr "XX" (ppTreeTrieMpKey kt >#< (ppTreeTrieMpKey $ updTKey $ replicate (5) (TTM1K [])) >#< ppTreeTrieMpKey kt' >#< ppTreeTrieMpKey k >#< maybe (pp "--") (\f -> ppTreeTrieMpKey $ f $ repeat (TTM1K [])) v) v) $ 
-                                             matchTreeTrieMpKeyTo kt' k
-                                 , isJust mbm
-                                 ]
-              
-              -- Match with possible wildcard in Key
-              TTL_WildInKey -> \updTKey mkRes (TreeTrieMpKey keys) ttrie ->
-                case keys of
-                  [] -> dflt mkRes ttrie
-                  (k : ks)
-                     -> (catMaybes mbs ++ concat subs, Nothing)
-                     where (subs,mbs)
-                             = unzip
-                                 [ case ks of
-                                     (ksk:ksks)                  -> l id (res mkRes kt) (TreeTrieKey $ fromJust m ksk : ksks) t
-                                     [] | Map.null (ttrieSubs t) -> l id (res mkRes kt) (TreeTrieKey []) t
-                                        | otherwise              -> l id (res mkRes kt) (TreeTrieKey [fromJust m $ repeat (TTM1K [])]) t
-                                 | (kt,t) <- Map.toList $ ttrieSubs ttrie
-                                 , let m = -- (\v -> tr "YY" (ppTreeTrieMpKey k >#< ppTreeTrieMpKey kt >#< maybe (pp "--") (\f -> ppTreeTrieMpKey $ f $ repeat (TTM1K [])) v) v) $ 
-                                           matchTreeTrieMpKeyTo k kt
-                                 , isJust m
-                                 ]
-          
-          -- Utils
-          where dflt mkRes ttrie = ([],fmap (mkRes []) $ ttrieMbVal ttrie)
-                res mkRes k = \ks v -> mkRes (k : ks) v
-
-lookupPartialByKey :: (PP k,Ord k) => TreeTrieLookup -> TreeTrieKey k -> TreeTrie k v -> ([v],Maybe v)
-lookupPartialByKey = lookupPartialByKey' (\_ v -> v)
-
-lookupByKey, lookup :: (PP k,Ord k) => TreeTrieKey k -> TreeTrie k v -> Maybe v
-lookupByKey keys ttrie = snd $ lookupPartialByKey TTL_WildInTrie keys ttrie
-
-lookup = lookupByKey
-
--- | Convert the lookup result to a list of results
-lookupResultToList :: ([v],Maybe v) -> [v]
-lookupResultToList (vs,mv) = maybeToList mv ++ vs
-
--}
-
--------------------------------------------------------------------------------------------
---- Observation
--------------------------------------------------------------------------------------------
-
-
-isEmpty :: TreeTrie k v -> Bool
-isEmpty ttrie
-  =  isNothing (ttrieMbVal ttrie)
-  && Map.null  (ttrieSubs ttrie)
-
-null :: TreeTrie k v -> Bool
-null = isEmpty
-
-elems :: TreeTrie k v -> [v]
-elems = map snd . toListByKey
-
--------------------------------------------------------------------------------------------
---- Construction
--------------------------------------------------------------------------------------------
-
-
-singleton :: Ord k => TreeTrieKey k -> v -> TreeTrie k v
-singleton (TreeTrieKey keys) val
-  = s keys
-  where s []       = TreeTrie (Just val) Map.empty
-        s (k : ks) = TreeTrie Nothing (Map.singleton k $ singleton (TreeTrieKey ks) val) 
-
-singletonKeyable :: (Ord (TrTrKey v),TreeTrieKeyable v) => v -> TreeTrie (TrTrKey v) v
-singletonKeyable val = singleton (toTreeTrieKey val) val
-
--------------------------------------------------------------------------------------------
---- Union, insert, ...
--------------------------------------------------------------------------------------------
-
-
-unionWith :: Ord k => (v -> v -> v) -> TreeTrie k v -> TreeTrie k v -> TreeTrie k v
-unionWith cmb t1 t2
-  = TreeTrie
-      { ttrieMbVal       = mkMb          cmb             (ttrieMbVal t1) (ttrieMbVal t2)
-      , ttrieSubs        = Map.unionWith (unionWith cmb) (ttrieSubs  t1) (ttrieSubs  t2)
-      }
-  where mkMb _   j         Nothing   = j
-        mkMb _   Nothing   j         = j
-        mkMb cmb (Just x1) (Just x2) = Just $ cmb x1 x2
-
-union :: Ord k => TreeTrie k v -> TreeTrie k v -> TreeTrie k v
-union = unionWith const
-
-unionsWith :: Ord k => (v -> v -> v) -> [TreeTrie k v] -> TreeTrie k v
-unionsWith cmb [] = emptyTreeTrie
-unionsWith cmb ts = foldr1 (unionWith cmb) ts
-
-unions :: Ord k => [TreeTrie k v] -> TreeTrie k v
-unions = unionsWith const
-
-insertByKeyWith :: Ord k => (v -> v -> v) -> TreeTrieKey k -> v -> TreeTrie k v -> TreeTrie k v
-insertByKeyWith cmb keys val ttrie = unionsWith cmb [singleton keys val,ttrie]
-
-insertByKey :: Ord k => TreeTrieKey k -> v -> TreeTrie k v -> TreeTrie k v
-insertByKey = insertByKeyWith const
-
-insert :: Ord k => TreeTrieKey k -> v -> TreeTrie k v -> TreeTrie k v
-insert = insertByKey
-
-insertKeyable :: (Ord (TrTrKey v),TreeTrieKeyable v) => v -> TreeTrie (TrTrKey v) v -> TreeTrie (TrTrKey v) v
-insertKeyable val = insertByKey (toTreeTrieKey val) val
-
--------------------------------------------------------------------------------------------
---- Delete, ...
--------------------------------------------------------------------------------------------
-
-{-
-
-deleteByKey, delete :: Ord k => TreeTrieKey k -> TreeTrie k v -> TreeTrie k v
-deleteByKey (TreeTrieKey keys) ttrie
-  = d keys ttrie
-  where d [] t
-          = t {ttrieMbVal = Nothing}
-        d (k : ks) t
-          = case fmap (d ks) $ Map.lookup k $ ttrieSubs t of
-              Just c | isEmpty c -> t { ttrieSubs = k `Map.delete` ttrieSubs t }
-                     | otherwise -> t { ttrieSubs = Map.insert k c $ ttrieSubs t }
-              _                  -> t
-
-delete = deleteByKey
-
-deleteListByKey :: Ord k => [TreeTrieKey k] -> TreeTrie k v -> TreeTrie k v
-deleteListByKey keys ttrie = foldl (\t k -> deleteByKey k t) ttrie keys
-
--}
-
--------------------------------------------------------------------------------------------
---- Instances: Serialize
--------------------------------------------------------------------------------------------
-
-instance Serialize k => Serialize (TreeTrie1Key k) where
-  sput (TT1K_Any            ) = sputWord8 0
-  sput (TT1K_One   a        ) = sputWord8 1 >> sput a
-  sget
-    = do t <- sgetWord8
-         case t of
-            0 -> return TT1K_Any
-            1 -> liftM  TT1K_One         sget
-
-instance Serialize k => Serialize (TreeTrieMp1Key k) where
-  sput (TTM1K_Any            ) = sputWord8 0 -- >> sput a
-  sput (TTM1K       a        ) = sputWord8 1 >> sput a
-  sget
-    = do t <- sgetWord8
-         case t of
-            0 -> return TTM1K_Any     -- sget
-            1 -> liftM  TTM1K         sget
-
-instance (Ord k, Serialize k, Serialize v) => Serialize (TreeTrie k v) where
-  sput (TreeTrie a b) = sput a >> sput b
-  sget = liftM2 TreeTrie sget sget
-  
-instance (Serialize k) => Serialize (TreeTrieMpKey k)
-instance (Serialize k) => Serialize (TreeTrieKey k)
-
--------------------------------------------------------------------------------------------
---- Test
--------------------------------------------------------------------------------------------
-
-test1
-  = fromListByKey
-      [ ( TreeTrieKey
-          [ TreeTrieMpKey [TTM1K [TT1K_One "C"]]
-          , TreeTrieMpKey [TTM1K [TT1K_Any, TT1K_One "P"]]
-          , TreeTrieMpKey [TTM1K [TT1K_One "D", TT1K_One "F"], TTM1K []]
-          ] 
-        , "C (* D F) P" 
-        ) 
-      , ( TreeTrieKey 
-          [ TreeTrieMpKey [TTM1K [TT1K_One "C"]]
-          , TreeTrieMpKey [TTM1K [TT1K_One "B", TT1K_One "P"]]
-          , TreeTrieMpKey [TTM1K [TT1K_One "D", TT1K_One "F"], TTM1K []]
-          ]
-        , "C (B D F) P"
-        )
-      , ( TreeTrieKey
-          [ TreeTrieMpKey [TTM1K [TT1K_One "C"]]
-          , TreeTrieMpKey [TTM1K [TT1K_One "B", TT1K_One "P"]]
-          , TreeTrieMpKey [TTM1K [], TTM1K [TT1K_One "Q", TT1K_One "R"]]
-          ]
-        , "C B (P Q R)"
-        )
-      , ( TreeTrieKey
-          [ TreeTrieMpKey [TTM1K [TT1K_One "C"]]
-          , TreeTrieMpKey [TTM1K [TT1K_One "B", TT1K_Any]]
-          ]
-        , "C B *"
-        )
-      ]
-
-t1k1 = TreeTrieKey
-          [ TreeTrieMpKey [TTM1K [TT1K_One "C"]]
-          , TreeTrieMpKey [TTM1K [TT1K_Any, TT1K_One "P"]]
-          , TreeTrieMpKey [TTM1K [TT1K_One "D", TT1K_One "F"], TTM1K []]
-          ]
-
-{-
-m1 = fromJust 
-     $ fmap (\f -> f $ [TTM1K [], TTM1K [TT1K_One "Z"]])
-     $ matchTreeTrieMpKeyTo
-        [TTM1K [TT1K_Any, TT1K_One "P"]]
-        [TTM1K [TT1K_One "B", TT1K_One "P"]]
-
-m2 = fmap (\f -> f $ repeat (TTM1K []))
-     $ matchTreeTrieMpKeyTo
-        m1
-        [TTM1K [TT1K_One "D", TT1K_One "F"], TTM1K [TT1K_One "Z"]]
-
-m3 = fromJust 
-     $ fmap (\f -> f $ [TTM1K [TT1K_Any, TT1K_One "P"]])
-     $ matchTreeTrieMpKeyTo
-        [TTM1K [TT1K_One "C"]]
-        [TTM1K [TT1K_One "C"]]
-
-m4 = fmap (\f -> f $ repeat (TTM1K []))
-     $ matchTreeTrieMpKeyTo
-        m3
-        [TTM1K [TT1K_One "B", TT1K_One "P"]]
-
-m5 = fmap (\f -> f $ repeat (TTM1K []))
-     $ matchTreeTrieMpKeyTo
-        (fromJust m4)
-        [TTM1K [TT1K_One "D", TT1K_One "F"], TTM1K []]
-
-l1t1 = lookupPartialByKey' (,) TTL_Exact
-          [ [TTM1K [TT1K_One "C"]]
-          , [TTM1K [TT1K_Any, TT1K_One "P"]]
-          ]
-
-l2t1 = lookupPartialByKey' (,) TTL_WildInTrie
-          [ [TTM1K [TT1K_One "C"]]
-          , [TTM1K [TT1K_One "B", TT1K_One "P"]]
-          ]
-
-l3t1 = lookupPartialByKey' (,) TTL_WildInKey
-          [ [TTM1K [TT1K_One "C"]]
-          , [TTM1K [TT1K_Any, TT1K_One "P"]]
-          ]
-
-l4t1 = lookupPartialByKey' (,) TTL_WildInKey
-          [ [TTM1K [TT1K_Any :: TreeTrie1Key String]]
-          ]
-
-l5t1 = lookupPartialByKey' (,) TTL_WildInTrie
-          [ [TTM1K [TT1K_One "C"]]
-          , [TTM1K [TT1K_One "B", TT1K_One "P"]]
-          , [TTM1K [TT1K_One "D", TT1K_One "F"], TTM1K []]
-          ]
-
-l6t1 = lookupPartialByKey' (,) TTL_WildInKey
-          [ [TTM1K [TT1K_One "C"]]
-          , [TTM1K [TT1K_Any, TT1K_One "P"]]
-          , [TTM1K [TT1K_One "D", TT1K_One "F"], TTM1K []]
-          ]
-
--}
-
-{-
-
-          , [<[1:S:Prf]>,<[1:S:occ]>,<[*,1:S:\]>,<[],[*]>]
-              : [ Prove (m_10_0\l_12_0,<sc_1_0>,??)
-                  ==>
-                  (m_10_0 == (m_11_0 | ...)) \ l_12_0@off_13_0
-                  | [ Prove (m_11_0\l_12_0,<sc_1_0>,??)
-                    , Red (m_10_0\l_12_0,<sc_1_0>,??) < label l_12_0@off_13_0<sc_1_0> < [(m_11_0\l_12_0,<sc_1_0>,??)]]
-                , Prove ({||}\l_12_0,<sc_1_0>,??)
-                  ==>
-                  Red ({||}\l_12_0,<sc_1_0>,??) < label l_12_0@0<sc_1_0> < []]
-
-        [<[1:S:Prf]>,<[1:S:occ]>,<[1:S:[0,0],1:S:\]>,<[],[1:H:3]>,<[1:U:3_48_0_0,1:U:3_48_0_1]>]: 1
-
--}
-
-{-
-test2
-  = fromListByKey
-      [ ( [ [TTM1K [TT1K_One "P"]]
-          , [TTM1K [TT1K_One "O"]]
-          , [TTM1K [TT1K_Any, TT1K_One "SL"]]
-          , [TTM1K [], TTM1K [TT1K_Any]]
-          ]
-        , "P (O * (SL *))"
-        )
-      ]
-
-l1t2 = lookupPartialByKey' (,) TTL_WildInTrie
-          [ [TTM1K [TT1K_One "P"]]
-          , [TTM1K [TT1K_One "O"]]
-          , [TTM1K [TT1K_One "Sc", TT1K_One "SL"]]
-          , [TTM1K [], TTM1K [TT1K_One "3"]]
-          , [TTM1K [TT1K_One "3_48_0_0", TT1K_One "3_48_0_1"]]
-          ]
-
--}
-
-{-
-test3
-  = fromListByKey
-      [ ( [[TTM1K [TT1K_One "1:S:Prf"]]
-          ,[TTM1K [TT1K_One "1:S:occ"]]
-          ,[TTM1K [TT1K_Any, TT1K_One "1:H:Language.UHC.JS.ECMA.Types.ToJS"]]
-          ,[TTM1K [], TTM1K [TT1K_One "1:H:UHC.Base.Maybe",TT1K_Any]]
-          ,[TTM1K [TT1K_Any], TTM1K []]
-          ]
-        , "xx"
-        )
-      ]
-
-l1t3 = lookupPartialByKey' (,) TTL_WildInTrie
-        [[TTM1K [TT1K_One "1:S:Prf"]]
-        ,[TTM1K [TT1K_One "1:S:occ"]]
-        ,[TTM1K [TT1K_One "1:S:[0,0,0,0,0,0]", TT1K_One "1:H:Language.UHC.JS.ECMA.Types.ToJS"]]
-        ,[TTM1K [],TTM1K [TT1K_One "1:H:UHC.Base.Maybe", TT1K_One "1:H:Language.UHC.JS.ECMA.Types.JSAny"]]
-        ,[TTM1K [TT1K_One "1:H:Language.UHC.JS.ECMA.Types.JSAny"], TTM1K [TT1K_One "1:U:12_398_1_0"]]
-        ,[TTM1K [TT1K_One "1:H:Language.UHC.JS.ECMA.Types.JSObject_"], TTM1K []]
-        ,[TTM1K [TT1K_One "1:H:Language.UHC.JS.W3C.HTML5.NodePtr"]]
-        ]
-
-          
-
--}
-
-{-
-  , [<[1:S:Prf]>
-    ,<[1:S:occ]>
-    ,<[*,1:H:Language.UHC.JS.ECMA.Types.ToJS]>
-    ,<[],[1:H:UHC.Base.Maybe,*]>
-    ,<[*],[]>
-    ]
-
-, DBG lookups for
-  [<[1:S:Prf]>
-  ,<[1:S:occ]>
-  ,<[1:S:[0,0,0,0,0,0],1:H:Language.UHC.JS.ECMA.Types.ToJS]>
-  ,<[],[1:H:UHC.Base.Maybe,1:H:Language.UHC.JS.ECMA.Types.JSAny]>
-  ,<[1:H:Language.UHC.JS.ECMA.Types.JSAny],[1:U:12_398_1_0]>
-  ,<[1:H:Language.UHC.JS.ECMA.Types.JSObject_],[]>
-  ,<[1:H:Language.UHC.JS.W3C.HTML5.NodePtr]>
-  ]
-
--}
diff --git a/src/UHC/Util/Utils.hs b/src/UHC/Util/Utils.hs
--- a/src/UHC/Util/Utils.hs
+++ b/src/UHC/Util/Utils.hs
@@ -2,8 +2,10 @@
 {-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances, DefaultSignatures, UndecidableInstances #-}
 
 module UHC.Util.Utils
-  ( -- * Set
-    unionMapSet
+  ( module CHR.Utils
+  
+    -- * Set
+  , unionMapSet
 
     -- * Map
   , inverseMap
@@ -13,7 +15,8 @@
   
     -- * List
   , hdAndTl', hdAndTl
-  , maybeNull, maybeHd
+  -- , maybeNull
+  -- , maybeHd
   , wordsBy
   , initlast, initlast2
   , last'
@@ -21,9 +24,10 @@
   , listSaturate, listSaturateWith
   , spanOnRest
   , filterMb
-  , splitPlaces
-  , combineToDistinguishedEltsBy
+  -- , splitPlaces
+  -- , combineToDistinguishedEltsBy
   , partitionOnSplit
+  -- , zipWithN
   
     -- * Tuple
   , tup123to1, tup123to2
@@ -76,20 +80,20 @@
   , showUnprefixed
   
     -- * Ordering
-  , orderingLexic
-  , orderingLexicList
+  -- , orderingLexic
+  -- , orderingLexicList
   
     -- * Misc
-  , panic
+  -- , panic
   
-  , isSortedByOn
-  , sortOnLazy
-  , sortOn
-  , sortByOn
-  , groupOn
-  , groupByOn
-  , groupSortOn
-  , groupSortByOn
+  -- , isSortedByOn
+  -- , sortOnLazy
+  -- , sortOn
+  -- , sortByOn
+  -- , groupOn
+  -- , groupByOn
+  -- , groupSortOn
+  -- , groupSortByOn
   , nubOn
   
   , consecutiveBy
@@ -97,7 +101,7 @@
   , partitionAndRebuild
   
     -- * Maybe
-  , panicJust
+  -- , panicJust
   , ($?)
   , orMb
   , maybeAnd
@@ -122,6 +126,7 @@
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.Graph as Graph
+import CHR.Utils
 
 -------------------------------------------------------------------------
 -- Set
@@ -157,6 +162,7 @@
 hdAndTl = hdAndTl' (panic "hdAndTl")
 {-# INLINE hdAndTl  #-}
 
+{-
 maybeNull :: r -> ([a] -> r) -> [a] -> r
 maybeNull n f l = if null l then n else f l
 {-# INLINE maybeNull  #-}
@@ -164,6 +170,7 @@
 maybeHd :: r -> (a -> r) -> [a] -> r
 maybeHd n f = maybeNull n (f . head)
 {-# INLINE maybeHd  #-}
+-}
 
 -- | Split up in words by predicate
 wordsBy :: (a -> Bool) -> [a] -> [[a]]
@@ -256,6 +263,7 @@
           where (es1,es2) = splitAt (p-pos) es
                 spls = spl (pos + length es1) ps es2
 
+{-
 -- | Combine [[x1..xn],..,[y1..ym]] to [[x1..y1],[x2..y1],..,[xn..ym]].
 --   Each element [xi..yi] is distinct based on the the key k in xi==(k,_)
 combineToDistinguishedEltsBy :: (e -> e -> Bool) -> [[e]] -> [[e]]
@@ -270,6 +278,11 @@
                                      ls
                       ) l
 
+zipWithN :: ([x] -> y) -> [[x]] -> [y]
+zipWithN f l | any null l = []
+             | otherwise  = f (map head l) : zipWithN f (map tail l)
+-}
+
 -------------------------------------------------------------------------
 -- Tupling, untupling
 -------------------------------------------------------------------------
@@ -429,13 +442,16 @@
 -- Misc
 -------------------------------------------------------------------------
 
+{-
 -- | Error, with message
 panic m = error ("panic: " ++ m)
+-}
 
 -------------------------------------------------------------------------
 -- group/sort/nub combi's
 -------------------------------------------------------------------------
 
+{-
 isSortedByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> Bool
 isSortedByOn cmp sel l
   = isSrt l
@@ -471,6 +487,7 @@
 
 groupSortByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> [[a]]
 groupSortByOn cmp sel = groupByOn (\e1 e2 -> cmp e1 e2 == EQ) sel . sortByOn cmp sel
+-}
 
 nubOn :: Eq b => (a->b) -> [a] -> [a]
 nubOn sel = nubBy ((==) `on` sel) -- (\a1 a2 -> sel a1 == sel a2)
@@ -517,6 +534,7 @@
 -- Ordering
 -------------------------------------------------------------------------
 
+{-
 -- | Reduce compare results lexicographically to one compare result
 orderingLexicList :: [Ordering] -> Ordering
 orderingLexicList = foldr1 orderingLexic
@@ -526,14 +544,17 @@
 orderingLexic :: Ordering -> Ordering -> Ordering
 orderingLexic o1 o2 = if o1 == EQ then o2 else o1
 {-# INLINE orderingLexic #-}
+-}
 
 -------------------------------------------------------------------------
 -- Maybe
 -------------------------------------------------------------------------
 
+{-
 panicJust :: String -> Maybe a -> a
 panicJust m = maybe (panic m) id
 {-# INLINE panicJust #-}
+-}
 
 infixr 0  $?
 
diff --git a/src/UHC/Util/VarLookup.hs b/src/UHC/Util/VarLookup.hs
--- a/src/UHC/Util/VarLookup.hs
+++ b/src/UHC/Util/VarLookup.hs
@@ -1,159 +1,18 @@
-{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies #-}
-{-# LANGUAGE CPP #-}
-#if __GLASGOW_HASKELL__ >= 710
-#else
-{-# LANGUAGE OverlappingInstances #-}
-#endif
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Abstractions for looking up (type) variables in structures
 
 module UHC.Util.VarLookup
-    ( VarLookup(..)
-    , VarLookupKey
-    , VarLookupVal
-    
-    , varlookupResolveVarWithMetaLev
-    , varlookupResolveVar
-    , varlookupResolveValWithMetaLev
-    , varlookupResolveVal
+    ( module CHR.Data.VarLookup
     
-    -- , VarCompareHow(..)
+    , VarLookupCmb(..)
     
     , varlookupMap
-    
-    , varlookupResolveAndContinueM
-    
-    , VarLookupFix, varlookupFix
-    , varlookupFixDel
-    
-    , VarLookupCmb (..)
-    
-    -- , VarLookupBase (..)
-    
-    , VarLookupCmbFix, varlookupcmbFix
-    
-    , MetaLev
-    , metaLevVal
-    
-    , StackedVarLookup(..)
-    
     )
   where
 
-import           Control.Applicative
-import           Data.Maybe
-import           UHC.Util.Pretty
-import qualified Data.Set as Set
-
--------------------------------------------------------------------------------------------
---- Level of lookup
--------------------------------------------------------------------------------------------
-
--- | Level to lookup into
-type MetaLev = Int
-
--- | Base level (of values, usually)
-metaLevVal :: MetaLev
-metaLevVal = 0
-
--------------------------------------------------------------------------------------------
---- VarLookup: something which can lookup a value 'v' given a key 'k'.
--------------------------------------------------------------------------------------------
-
-
--- | Type family for key of a VarLookup
-type family VarLookupKey m :: *
--- | Type family for value of a VarLookup
-type family VarLookupVal m :: *
-
-{- |
-VarLookup abstracts from a Map.
-The purpose is to be able to combine maps only for the purpose of searching without actually merging the maps.
-This then avoids the later need to unmerge such mergings.
-The class interface serves to hide this.
--}
-
-class VarLookup m where
-  -- | Lookup a key at a level
-  varlookupWithMetaLev :: MetaLev -> VarLookupKey m -> m -> Maybe (VarLookupVal m)
-
-  -- | Lookup a key
-  varlookup :: VarLookupKey m -> m -> Maybe (VarLookupVal m)
-  varlookup = varlookupWithMetaLev metaLevVal
-  {-# INLINE varlookup #-}
-  
-  -- | Keys at a level
-  varlookupKeysSetWithMetaLev :: (Ord (VarLookupKey m)) => MetaLev -> m -> Set.Set (VarLookupKey m)
-  
-  -- | Keys as Set
-  varlookupKeysSet :: (Ord (VarLookupKey m)) => m -> Set.Set (VarLookupKey m)
-  varlookupKeysSet = varlookupKeysSetWithMetaLev metaLevVal
-  {-# INLINE varlookupKeysSet #-}
-
-  -- | Make an empty VarLookup
-  varlookupEmpty :: m
-  -- | Make a singleton VarLookup at a level
-  varlookupSingletonWithMetaLev :: MetaLev -> VarLookupKey m -> VarLookupVal m -> m
-  
-  -- | Make a singleton VarLookup
-  varlookupSingleton :: VarLookupKey m -> VarLookupVal m -> m
-  varlookupSingleton = varlookupSingletonWithMetaLev metaLevVal
-  {-# INLINE varlookupSingleton #-}
-
--------------------------------------------------------------------------------------------
---- Util/convenience
--------------------------------------------------------------------------------------------
-
--- | Combine lookup with map; should be obsolete...
-varlookupMap :: VarLookup m => (VarLookupVal m -> Maybe res) -> VarLookupKey m -> m -> Maybe res
-varlookupMap get k m = varlookup k m >>= get
-{-# INLINE varlookupMap #-}
-
--------------------------------------------------------------------------------------------
---- Lookup and resolution
--------------------------------------------------------------------------------------------
-
--- | Fully resolve lookup
-varlookupResolveVarWithMetaLev :: VarLookup m => MetaLev -> (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupKey m -> m -> Maybe (VarLookupVal m)
-varlookupResolveVarWithMetaLev l isVar k m =
-  varlookupWithMetaLev l k m >>= \v -> varlookupResolveValWithMetaLev l isVar v m <|> return v
-
--- | Fully resolve lookup
-varlookupResolveVar :: VarLookup m => (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupKey m -> m -> Maybe (VarLookupVal m)
-varlookupResolveVar = varlookupResolveVarWithMetaLev metaLevVal
-{-# INLINE varlookupResolveVar #-}
-
-varlookupResolveValWithMetaLev :: VarLookup m => MetaLev -> (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupVal m -> m -> Maybe (VarLookupVal m)
-varlookupResolveValWithMetaLev l isVar v m = isVar v >>= \k -> varlookupResolveVarWithMetaLev l isVar k m <|> return v
-
--- | Fully resolve lookup
-varlookupResolveVal :: VarLookup m => (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupVal m -> m -> Maybe (VarLookupVal m)
-varlookupResolveVal = varlookupResolveValWithMetaLev metaLevVal
-{-# INLINE varlookupResolveVal #-}
-
--- | Monadically lookup a variable, resolve it, continue with either a fail or success monad continuation
-varlookupResolveAndContinueM :: (Monad m, VarLookup s) => (VarLookupVal s -> Maybe (VarLookupKey s)) -> (m s) -> (m a) -> (VarLookupVal s -> m a) -> VarLookupKey s -> m a
-varlookupResolveAndContinueM tmIsVar gets failFind okFind k = gets >>= \s -> maybe failFind okFind $ varlookupResolveVar tmIsVar k s
-
--------------------------------------------------------------------------------------------
---- VarLookupFix
--------------------------------------------------------------------------------------------
-
--- (not yet, still in use in UHC) {-# DEPRECATED VarLookupFix, varlookupFix, varlookupFixDel "As of 20160331: don't use these anymore" #-}
-
-type VarLookupFix k v = k -> Maybe v
-
--- | fix looking up to be for a certain var mapping
-varlookupFix :: VarLookup m => m -> VarLookupFix (VarLookupKey m) (VarLookupVal m)
-varlookupFix m = \k -> varlookup k m
-
--- | simulate deletion
-varlookupFixDel :: Ord k => [k] -> VarLookupFix k v -> VarLookupFix k v
-varlookupFixDel ks f = \k -> if k `elem` ks then Nothing else f k
-
--------------------------------------------------------------------------------------------
---- VarLookupCmb: combine VarLookups
--------------------------------------------------------------------------------------------
+import           CHR.Data.VarLookup
+import qualified CHR.Data.Lookup as Lk
 
 {- |
 VarLookupCmb abstracts the 'combining' of/from a substitution.
@@ -167,82 +26,15 @@
 
 infixr 7 |+>
 
-{-
-#if __GLASGOW_HASKELL__ >= 710
-instance {-# OVERLAPPING #-}
-#else
-instance
-#endif
-  VarLookupCmb m1 m2 => VarLookupCmb m1 [m2] where
-    m1 |+> (m2:m2s) = (m1 |+> m2) : m2s
--}
-
-{-
-#if __GLASGOW_HASKELL__ >= 710
-instance {-# OVERLAPPING #-}
-#else
-instance
-#endif
-  (VarLookupCmb m1 m1, VarLookupCmb m1 m2) => VarLookupCmb [m1] [m2] where
-    m1 |+> (m2:m2s) = (foldr1 (|+>) m1 |+> m2) : m2s
--}
-
-{-
-instance
-  (VarLookupCmb m1 m1, VarLookupCmb m1 m2) => VarLookupCmb (StackedVarLookup m1) (StackedVarLookup m2) where
-    m1 |+> StackedVarLookup (m2:m2s) = StackedVarLookup $ (foldr1 (|+>) m1 |+> m2) : m2s
--}
-
--------------------------------------------------------------------------------------------
---- How to do the VarLookup part of matching/unification/comparing
--------------------------------------------------------------------------------------------
-
-{-
--- | How to match, increasingly more binding is allowed
-data VarCompareHow
-  = VarCompareHow_Check               -- ^ equality check only
-  | VarCompareHow_Match               -- ^ also allow one-directional (left to right) matching/binding of (meta)vars
-  | VarCompareHow_MatchAndWait        -- ^ also allow giving back of global vars on which we wait
-  | VarCompareHow_Unify               -- ^ also allow bi-directional matching, i.e. unification
-  deriving (Ord, Eq)
--}
-
--------------------------------------------------------------------------------------------
---- VarLookupCmbFix
--------------------------------------------------------------------------------------------
-
-{-# DEPRECATED VarLookupCmbFix, varlookupcmbFix "As of 20160331: don't use these anymore" #-}
-type VarLookupCmbFix m1 m2 = m1 -> m2 -> m2
-
--- | fix combining up to be for a certain var mapping
-varlookupcmbFix :: VarLookupCmb m1 m2 => VarLookupCmbFix m1 m2
-varlookupcmbFix m1 m2 = m1 |+> m2
+-- build on LookupApply, if available
+instance {-# OVERLAPPABLE #-} Lk.LookupApply m1 m2 => VarLookupCmb m1 m2 where
+  (|+>) = Lk.apply
 
 -------------------------------------------------------------------------------------------
---- Stack of things in which we can lookup, but which is updated only at the top
+--- Util/convenience
 -------------------------------------------------------------------------------------------
 
--- | Stacked VarLookup derived from a base one, to allow a use of multiple lookups but update on top only
-newtype StackedVarLookup s = StackedVarLookup {unStackedVarLookup :: [s]}
-  deriving Foldable
-
-type instance VarLookupKey (StackedVarLookup s) = VarLookupKey s
-type instance VarLookupVal (StackedVarLookup s) = VarLookupVal s
-
-instance Show (StackedVarLookup s) where
-  show _ = "StackedVarLookup"
-
-instance PP s => PP (StackedVarLookup s) where
-  pp (StackedVarLookup xs) = ppCurlysCommas $ map pp xs
-
-instance (VarLookup m) => VarLookup (StackedVarLookup m) where
-  varlookupWithMetaLev l k (StackedVarLookup ms) = listToMaybe $ catMaybes $ map (varlookupWithMetaLev l k) ms
-  varlookupKeysSetWithMetaLev l (StackedVarLookup ms) = Set.unions $ map (varlookupKeysSetWithMetaLev l) ms
-  varlookupEmpty = StackedVarLookup [varlookupEmpty]
-  {-# INLINE varlookupEmpty #-}
-  varlookupSingletonWithMetaLev l k v = StackedVarLookup [varlookupSingletonWithMetaLev l k v]
-  {-# INLINE varlookupSingletonWithMetaLev #-}
-
-instance VarLookupCmb m1 m2 => VarLookupCmb m1 (StackedVarLookup m2) where
-  m1 |+> StackedVarLookup (m2:m2s) = StackedVarLookup $ (m1 |+> m2) : m2s
-
+-- | Combine lookup with map; should be obsolete...
+varlookupMap :: VarLookup m => (VarLookupVal m -> Maybe res) -> VarLookupKey m -> m -> Maybe res
+varlookupMap get k m = varlookup k m >>= get
+{-# INLINE varlookupMap #-}
diff --git a/src/UHC/Util/VarMp.hs b/src/UHC/Util/VarMp.hs
--- a/src/UHC/Util/VarMp.hs
+++ b/src/UHC/Util/VarMp.hs
@@ -22,572 +22,12 @@
 {-# LANGUAGE DeriveGeneric #-}
 
 module UHC.Util.VarMp
-    ( VarMp'(..)
-    -- , VarMp
-    , ppVarMpV
-    -- , vmiMbTy
-    -- , tyAsVarMp', tyAsVarMp
-    -- , varmpFilterTy
-    , varmpFilter
-    , varmpDel, (|\>)
-    , varmpAlter
-    , varmpUnion, varmpUnions
-    --, varmpTyLookupCyc
-    --, varmpTyLookupCyc2
-    , module UHC.Util.VarLookup
-    -- , VarMpInfo (..)
-    , mkVarMp
-    , emptyVarMp, varmpIsEmpty
-    , varmpShiftMetaLev, varmpIncMetaLev, varmpDecMetaLev
-    , varmpSelectMetaLev
-    , varmpKeys, varmpKeysSet
-    , varmpMetaLevSingleton, varmpSingleton
-    , assocMetaLevLToVarMp, assocLToVarMp
-    -- , assocMetaLevTyLToVarMp, assocTyLToVarMp, varmpToAssocTyL
-    , varmpToAssocL
-    , varmpPlus
-    , varmpUnionWith
-    -- , instToL1VarMp
-    -- , varmpMetaLevTyUnit, varmpTyUnit
-    -- , tyRestrictKiVarMp
-    , varmpLookup
-    -- , varmpTyLookup
-    , ppVarMp
-    , varmpAsMap
-    , varmpMapMaybe, varmpMap
-    , varmpInsertWith
-{-
-    , VarMpStk'
-    , emptyVarMpStk, varmpstkUnit
-    , varmpstkPushEmpty, varmpstkPop
-    , varmpstkToAssocL, varmpstkKeysSet
-    , varmpstkUnions
--}
-    , varmpSize
-    -- , vmiMbImpls, vmiMbScope, vmiMbPred, vmiMbAssNm
-    -- , varmpTailAddOcc
-    -- , varmpMapThr
-    -- , varmpMapThrTy
-    -- , varmpImplsUnit, assocImplsLToVarMp, varmpScopeUnit, varmpPredUnit, varmpAssNmUnit
-    -- , varmpImplsLookup, varmpScopeLookup, varmpPredLookup
-    -- , varmpImplsLookupImplsCyc, varmpImplsLookupCyc, varmpScopeLookupScopeCyc, varmpAssNmLookupAssNmCyc
-    -- , varmpPredLookup2, varmpScopeLookup2, varmpAssNmLookup2, varmpImplsLookupCyc2
-    -- , vmiMbLabel, vmiMbOffset
-    -- , varmpLabelUnit, varmpOffsetUnit
-    -- , varmpLabelLookup, varmpOffsetLookup
-    -- , varmpLabelLookupCyc, varmpLabelLookupLabelCyc
-    -- , vmiMbPredSeq
-    -- , varmpPredSeqUnit
-    -- , varmpPredSeqLookup
-    , varmpToMap
-    -- , varmpinfoMkVar
-    -- , ppVarMpInfoCfgTy, ppVarMpInfoDt
+    ( module CHR.Data.VarMp
     )
   where
 
-import Data.List
--- import EH100.Base.Common
--- import EH100.Ty
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.Maybe
-import UHC.Util.Pretty
--- import EH100.Ty.Pretty
--- import EH100.Error
-import UHC.Util.AssocL
-import UHC.Util.VarLookup
--- import EH100.Base.Debug
-import UHC.Util.Utils
-import Control.Monad
-import Data.Typeable (Typeable)
--- import Data.Generics (Data)
--- import EH100.Base.Binary
+import CHR.Data.VarMp
 import UHC.Util.Serialize
-
-
-
-
-
-
-data VarMp' k v
-  = VarMp
-      { varmpMetaLev    :: !MetaLev             -- ^ the base meta level
-      , varmpMpL        :: [Map.Map k v]        -- ^ for each level a map, starting at the base meta level
-      }
-  deriving (Eq, Ord, Typeable, Generic)
-
-type instance VarLookupKey (VarMp' k v) = k
-type instance VarLookupVal (VarMp' k v) = v
-
--- get the base meta level map, ignore the others
-varmpToMap :: VarMp' k v -> Map.Map k v
-varmpToMap (VarMp _ (m:_)) = m
-{-# INLINE varmpToMap #-}
-
-mkVarMp :: Map.Map k v -> VarMp' k v
-mkVarMp m = VarMp 0 [m]
-{-# INLINE mkVarMp #-}
-
-emptyVarMp :: VarMp' k v
-emptyVarMp = mkVarMp Map.empty
-{-# INLINE emptyVarMp #-}
-
-varmpIsEmpty :: VarMp' k v -> Bool
-varmpIsEmpty (VarMp {varmpMpL=l}) = all Map.null l
-
-varmpFilter :: Ord k => (k -> v -> Bool) -> VarMp' k v -> VarMp' k v
-varmpFilter f (VarMp l c) = VarMp l (map (Map.filterWithKey f) c)
-
-varmpPartition :: Ord k => (k -> v -> Bool) -> VarMp' k v -> (VarMp' k v,VarMp' k v)
-varmpPartition f (VarMp l m)
-  = (VarMp l p1, VarMp l p2)
-  where (p1,p2) = unzip $ map (Map.partitionWithKey f) m
-
-(|\>) :: Ord k => VarMp' k v -> [k] -> VarMp' k v
-(|\>) = flip varmpDel
-
--- | Delete
-varmpDel :: Ord k => [k] -> VarMp' k v -> VarMp' k v
-varmpDel tvL c = varmpFilter (const.not.(`elem` tvL)) c
-
--- | Alter irrespective of level
-varmpAlter :: Ord k => (Maybe v -> Maybe v) -> k -> VarMp' k v -> VarMp' k v
-varmpAlter f k (VarMp l c) = VarMp l (map (Map.alter f k) c)
-
--- shift up the level,
--- or down when negative, throwing away the lower levels
-varmpShiftMetaLev :: MetaLev -> VarMp' k v -> VarMp' k v
-varmpShiftMetaLev inc (VarMp mlev fm)
-  | inc < 0   = let mlev' = mlev+inc in VarMp (mlev' `max` 0) (drop (- (mlev' `min` 0)) fm)
-  | otherwise = VarMp (mlev+inc) fm
-
-varmpIncMetaLev :: VarMp' k v -> VarMp' k v
-varmpIncMetaLev = varmpShiftMetaLev 1
-
-varmpDecMetaLev :: VarMp' k v -> VarMp' k v
-varmpDecMetaLev = varmpShiftMetaLev (-1)
-
-varmpSelectMetaLev :: [MetaLev] -> VarMp' k v -> VarMp' k v
-varmpSelectMetaLev mlevs (VarMp mlev ms)
-  = (VarMp mlev [ if l `elem` mlevs then m else Map.empty | (l,m) <- zip [mlev..] ms ])
-
--- | Extract first level map, together with a construction function putting a new map into the place of the previous one
-varmpAsMap :: VarMp' k v -> (Map.Map k v, Map.Map k v -> VarMp' k v)
-varmpAsMap (VarMp mlev (m:ms)) = (m, \m' -> VarMp mlev (m':ms))
-
--- VarMp: properties
-
-varmpSize :: VarMp' k v -> Int
-varmpSize (VarMp _ m) = sum $ map Map.size m
-
-varmpKeys :: Ord k => VarMp' k v -> [k]
-varmpKeys (VarMp _ fm) = Map.keys $ Map.unions fm
-
-varmpKeysSet :: Ord k => VarMp' k v -> Set.Set k
-varmpKeysSet (VarMp _ fm) = Set.unions $ map Map.keysSet fm
-
-{-# DEPRECATED varmpMetaLevSingleton "Use varlookupSingletonWithMetaLev" #-}
--- | VarMp singleton
-varmpMetaLevSingleton :: Ord k => MetaLev -> k -> v -> VarMp' k v
-varmpMetaLevSingleton = varlookupSingletonWithMetaLev
-{-# INLINE varmpMetaLevSingleton #-}
-
--- (not yet) {-# DEPRECATED varmpSingleton "Use varlookupSingleton" #-}
--- | VarMp singleton
-varmpSingleton :: Ord k => k -> v -> VarMp' k v
-varmpSingleton = varlookupSingleton
-{-# INLINE varmpSingleton #-}
-
-assocMetaLevLToVarMp :: Ord k => AssocL k (MetaLev,v) -> VarMp' k v
-assocMetaLevLToVarMp l = varmpUnions [ varlookupSingletonWithMetaLev lev k v | (k,(lev,v)) <- l ]
-
-assocLToVarMp :: Ord k => AssocL k v -> VarMp' k v
-assocLToVarMp = mkVarMp . Map.fromList
-
-{-
-assocMetaLevTyLToVarMp :: Ord k => AssocL k (MetaLev,Ty) -> VarMp' k VarMpInfo
-assocMetaLevTyLToVarMp = assocMetaLevLToVarMp . assocLMapElt (\(ml,t) -> (ml, VMITy t)) -- varmpUnions [ varmpMetaLevTyUnit lev v t | (v,(lev,t)) <- l ]
-
-assocTyLToVarMp :: Ord k => AssocL k Ty -> VarMp' k VarMpInfo
-assocTyLToVarMp = assocLToVarMp . assocLMapElt VMITy
--}
-
-varmpToAssocL :: VarMp' k i -> AssocL k i
-varmpToAssocL (VarMp _ []   ) = []
-varmpToAssocL (VarMp _ (l:_)) = Map.toList l
-
-{-
-varmpToAssocTyL :: VarMp' k VarMpInfo -> AssocL k Ty
-varmpToAssocTyL c = [ (v,t) | (v,VMITy t) <- varmpToAssocL c ]
--}
-
--- VarMp: combine
-
-infixr 7 `varmpPlus`
-
-varmpPlus :: Ord k => VarMp' k v -> VarMp' k v -> VarMp' k v
-varmpPlus = (|+>) -- (VarMp l1) (VarMp l2) = VarMp (l1 `Map.union` l2)
-
-varmpUnion :: Ord k => VarMp' k v -> VarMp' k v -> VarMp' k v
-varmpUnion = varmpPlus
-
-varmpUnions :: Ord k => [VarMp' k v] -> VarMp' k v
-varmpUnions [ ] = emptyVarMp
-varmpUnions [x] = x
-varmpUnions l   = foldr1 varmpPlus l
-
--- | combine by taking the lowest level, adapting the lists with maps accordingly
-varmpUnionWith :: Ord k => (v -> v -> v) -> VarMp' k v -> VarMp' k v -> VarMp' k v
-varmpUnionWith f (VarMp l1 ms1) (VarMp l2 ms2)
-  = case compare l1 l2 of
-      EQ -> VarMp l1 (cmb                                   ms1                                    ms2 )
-      LT -> VarMp l1 (cmb                                   ms1  (replicate (l2 - l1) Map.empty ++ ms2))
-      GT -> VarMp l2 (cmb (replicate (l1 - l2) Map.empty ++ ms1)                                   ms2 )
-  where cmb (m1:ms1) (m2:ms2) = Map.unionWith f m1 m2 : cmb ms1 ms2
-        cmb ms1      []       = ms1
-        cmb []       ms2      = ms2
-
--- Fold: map
-
-varmpMapMaybe :: Ord k => (a -> Maybe b) -> VarMp' k a -> VarMp' k b
-varmpMapMaybe f m = m {varmpMpL = map (Map.mapMaybe f) $ varmpMpL m}
-
-varmpMap :: Ord k => (a -> b) -> VarMp' k a -> VarMp' k b
-varmpMap f m = m {varmpMpL = map (Map.map f) $ varmpMpL m}
-
--- Insertion
-
-varmpInsertWith :: Ord k => (v -> v -> v) -> k -> v -> VarMp' k v -> VarMp' k v
-varmpInsertWith f k v = varmpUnionWith f (varmpSingleton k v)
-
--- Lookup as VarLookup
-
-instance Ord k => VarLookup (VarMp' k v) where
-  varlookupWithMetaLev l k    (VarMp vmlev ms) = lkup (l-vmlev) ms
-                                               where lkup _ []     = Nothing
-                                                     lkup 0 (m:_)  = Map.lookup k m
-                                                     lkup l (_:ms) = lkup (l-1) ms
-  varlookup              k vm@(VarMp vmlev _ ) = varlookupWithMetaLev vmlev k vm
-  varlookupKeysSetWithMetaLev l (VarMp vmlev ms) = Map.keysSet $ ms !! (l-vmlev)
-  varlookupKeysSet              (VarMp _     ms) = Set.unions $ map Map.keysSet ms
-  varlookupEmpty = emptyVarMp
-  {-# INLINE varlookupEmpty #-}
-  varlookupSingletonWithMetaLev l k v = VarMp l [Map.singleton k v]
-  {-# INLINE varlookupSingletonWithMetaLev #-}
-
-
-instance Ord k => VarLookupCmb (VarMp' k v) (VarMp' k v) where
-  m1 |+> m2 = varmpUnionWith const m1 m2
-
-{-
-instToL1VarMp :: [InstTo] -> VarMp
-instToL1VarMp = varmpIncMetaLev . assocMetaLevTyLToVarMp . instToL1AssocL
--}
-
-{-
-data VarMpInfo
-  = VMITy      !Ty
-  | VMIImpls   !Impls
-  | VMIScope   !PredScope
-  | VMIPred    !Pred
-  | VMIAssNm   !VarUIDHsName
-  | VMILabel   !Label
-  | VMIOffset  !LabelOffset
---  | VMIExts    !RowExts
-  | VMIPredSeq !PredSeq
-  deriving
-    ( Eq, Ord, Show
-    , Typeable, Data
-    )
-
-vmiMbTy      i = case i of {VMITy      x -> Just x; _ -> Nothing}
-
-vmiMbImpls   i = case i of {VMIImpls   x -> Just x; _ -> Nothing}
-vmiMbScope   i = case i of {VMIScope   x -> Just x; _ -> Nothing}
-vmiMbPred    i = case i of {VMIPred    x -> Just x; _ -> Nothing}
-vmiMbAssNm   i = case i of {VMIAssNm   x -> Just x; _ -> Nothing}
-vmiMbLabel   i = case i of {VMILabel   x -> Just x; _ -> Nothing}
-vmiMbOffset  i = case i of {VMIOffset  x -> Just x; _ -> Nothing}
-vmiMbPredSeq i = case i of {VMIPredSeq x -> Just x; _ -> Nothing}
-
-type VarMp  = VarMp' TyVarId VarMpInfo
--}
-
-instance Show (VarMp' k v) where
-  show _ = "VarMp"
-
-{-
-varmpFilterTy :: Ord k => (k -> Ty -> Bool) -> VarMp' k VarMpInfo -> VarMp' k VarMpInfo
-varmpFilterTy f
-  = varmpFilter
-        (\v i -> case i of {VMITy t -> f v t ; _ -> True})
-
-varmpTailAddOcc :: ImplsProveOcc -> Impls -> (Impls,VarMp)
-varmpTailAddOcc o (Impls_Tail i os) = (t, varmpImplsUnit i t)
-                                    where t = Impls_Tail i (o:os)
-varmpTailAddOcc _ x                 = (x,emptyVarMp)
--}
-
-{-
-varmpMapThr :: (MetaLev -> TyVarId -> VarMpInfo -> thr -> (VarMpInfo,thr)) -> thr -> VarMp -> (VarMp,thr)
-varmpMapThr f thr (VarMp l ms)
-  = (VarMp l ms',thr')
-  where (ms',thr') = foldMlev thr ms
-        foldMp mlev thr fm
-          = Map.foldrWithKey
-              (\v i (fm,thr)
-                 -> let  (i',thr') = f mlev v i thr
-                    in   (Map.insert v i' fm,thr')
-              )
-              (Map.empty,thr) fm
-        foldMlev thr ms
-          = foldr
-              (\(mlev,m) (ms,thr)
-                -> let (m',thr') = foldMp mlev thr m
-                   in  (m':ms,thr')
-              )
-              ([],thr) (zip [0..] ms)
--}
-
-{-
-varmpMapThrTy :: (MetaLev -> TyVarId -> Ty -> thr -> (Ty,thr)) -> thr -> VarMp -> (VarMp,thr)
-varmpMapThrTy f
-  = varmpMapThr
-      (\mlev v i thr
-         -> case i of
-              VMITy t -> (VMITy t,thr')
-                      where (t',thr') = f mlev v t thr
-              _       -> (i,thr)
-      )
-
-varmpinfoMkVar :: TyVarId -> VarMpInfo -> Ty
-varmpinfoMkVar v i
-  = case i of
-      VMITy       t -> mkTyVar v
-      VMIImpls    i -> mkImplsVar v
-      _             -> mkTyVar v                    -- rest incomplete
-
-varmpMetaLevTyUnit :: Ord k => MetaLev -> k -> Ty -> VarMp' k VarMpInfo
-varmpMetaLevTyUnit mlev v t = varlookupSingletonWithMetaLev mlev v (VMITy t)
-
-varmpTyUnit :: Ord k => k -> Ty -> VarMp' k VarMpInfo
-varmpTyUnit = varmpMetaLevTyUnit metaLevVal
-
-varmpImplsUnit :: ImplsVarId -> Impls -> VarMp
-varmpImplsUnit v i = mkVarMp (Map.fromList [(v,VMIImpls i)])
-
-varmpScopeUnit :: TyVarId -> PredScope -> VarMp
-varmpScopeUnit v sc = mkVarMp (Map.fromList [(v,VMIScope sc)])
-
-varmpPredUnit :: TyVarId -> Pred -> VarMp
-varmpPredUnit v p = mkVarMp (Map.fromList [(v,VMIPred p)])
-
-varmpAssNmUnit :: TyVarId -> VarUIDHsName -> VarMp
-varmpAssNmUnit v p = mkVarMp (Map.fromList [(v,VMIAssNm p)])
-
-assocImplsLToVarMp :: AssocL ImplsVarId Impls -> VarMp
-assocImplsLToVarMp = mkVarMp . Map.fromList . assocLMapElt VMIImpls
-
-varmpLabelUnit :: LabelVarId -> Label -> VarMp
-varmpLabelUnit v l = mkVarMp (Map.fromList [(v,VMILabel l)])
-
-varmpOffsetUnit :: UID -> LabelOffset -> VarMp
-varmpOffsetUnit v l = mkVarMp (Map.fromList [(v,VMIOffset l)])
-
-
-varmpPredSeqUnit :: TyVarId -> PredSeq -> VarMp
-varmpPredSeqUnit v l = mkVarMp (Map.fromList [(v,VMIPredSeq l)])
-
--- restrict the kinds of tvars bound to value identifiers to kind *
-tyRestrictKiVarMp :: [Ty] -> VarMp
-tyRestrictKiVarMp ts = varmpIncMetaLev $ assocTyLToVarMp [ (v,kiStar) | t <- ts, v <- maybeToList $ tyMbVar t ]
-
--- | Encode 'ty' as a tvar + VarMp, with additional initial construction
-tyAsVarMp' :: (UID -> Ty -> Ty) -> UID -> Ty -> (Ty,VarMp)
-tyAsVarMp' f u t
-  = case f v1 t of
-      t | tyIsVar t -> (t, emptyVarMp)
-        | otherwise -> (mkTyVar v2, varmpTyUnit v2 t)
-  where [v1,v2] = mkNewLevUIDL 2 u
-
--- | Encode 'ty' as a tvar + VarMp
-tyAsVarMp :: UID -> Ty -> (Ty,VarMp)
-tyAsVarMp = tyAsVarMp' (flip const)
--}
-
-varmpLookup :: (VarLookup m, Ord (VarLookupKey m)) => VarLookupKey m -> m -> Maybe (VarLookupVal m)
-varmpLookup = varlookup -- varlookupMap (Just . id)
-{-# INLINE varmpLookup #-}
-
-{-
-varmpTyLookup :: (VarLookup m k VarMpInfo,Ord k) => k -> m -> Maybe Ty
-varmpTyLookup = varlookupMap vmiMbTy
-
-varmpImplsLookup :: VarLookup m ImplsVarId VarMpInfo => ImplsVarId -> m -> Maybe Impls
-varmpImplsLookup = varlookupMap vmiMbImpls
-
-varmpScopeLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe PredScope
-varmpScopeLookup = varlookupMap vmiMbScope
-
-varmpPredLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe Pred
-varmpPredLookup = varlookupMap vmiMbPred
-
-varmpAssNmLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe VarUIDHsName
-varmpAssNmLookup = varlookupMap vmiMbAssNm
-
-varmpLabelLookup :: VarLookup m LabelVarId VarMpInfo => LabelVarId -> m -> Maybe Label
-varmpLabelLookup = varlookupMap vmiMbLabel
-
-varmpOffsetLookup :: VarLookup m UID VarMpInfo => UID -> m -> Maybe LabelOffset
-varmpOffsetLookup = varlookupMap vmiMbOffset
-
-varmpPredSeqLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe PredSeq
-varmpPredSeqLookup = varlookupMap vmiMbPredSeq
-
-varmpTyLookupCyc :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe Ty
-varmpTyLookupCyc x m = lookupLiftCycMb2 tyMbVar (flip varmpTyLookup m) x
-
-varmpImplsLookupImplsCyc :: VarLookup m ImplsVarId VarMpInfo => Impls -> m -> Maybe Impls
-varmpImplsLookupImplsCyc x m = lookupLiftCycMb1 implsMbVar (flip varmpImplsLookup m) x
-
-varmpImplsLookupCyc :: VarLookup m ImplsVarId VarMpInfo => TyVarId -> m -> Maybe Impls
-varmpImplsLookupCyc x m = lookupLiftCycMb2 implsMbVar (flip varmpImplsLookup m) x
-
-varmpScopeLookupScopeCyc :: VarLookup m ImplsVarId VarMpInfo => PredScope -> m -> Maybe PredScope
-varmpScopeLookupScopeCyc x m = lookupLiftCycMb1 pscpMbVar (flip varmpScopeLookup m) x
-
-varmpAssNmLookupAssNmCyc :: VarLookup m ImplsVarId VarMpInfo => VarUIDHsName -> m -> Maybe VarUIDHsName
-varmpAssNmLookupAssNmCyc x m = lookupLiftCycMb1 vunmMbVar (flip varmpAssNmLookup m) x
-
-varmpLabelLookupLabelCyc :: VarLookup m ImplsVarId VarMpInfo => Label -> m -> Maybe Label
-varmpLabelLookupLabelCyc x m = lookupLiftCycMb1 labelMbVar (flip varmpLabelLookup m) x
-
-varmpLabelLookupCyc :: VarLookup m ImplsVarId VarMpInfo => TyVarId -> m -> Maybe Label
-varmpLabelLookupCyc x m = lookupLiftCycMb2 labelMbVar (flip varmpLabelLookup m) x
-
-varmpTyLookupCyc2 :: VarMp -> TyVarId -> Maybe Ty
-varmpTyLookupCyc2 x m = varmpTyLookupCyc m x
-
-varmpScopeLookup2 :: VarMp -> TyVarId -> Maybe PredScope
-varmpScopeLookup2 m v = varmpScopeLookup v m
-
-varmpImplsLookup2 :: VarMp -> ImplsVarId -> Maybe Impls
-varmpImplsLookup2 m v = varmpImplsLookup v m
-
-varmpImplsLookupCyc2 :: VarMp -> ImplsVarId -> Maybe Impls
-varmpImplsLookupCyc2 m v = varmpImplsLookupCyc v m
-
-varmpPredLookup2 :: VarMp -> TyVarId -> Maybe Pred
-varmpPredLookup2 m v = varmpPredLookup v m
-
-varmpAssNmLookup2 :: VarMp -> TyVarId -> Maybe VarUIDHsName
-varmpAssNmLookup2 m v = varmpAssNmLookup v m
-
-varmpLabelLookup2 :: VarMp -> LabelVarId -> Maybe Label
-varmpLabelLookup2 m v = varmpLabelLookup v m
--}
-
--- VarMp stack, for nested/local behavior
-
-{-
-newtype VarMpStk' k v
-  = VarMpStk [VarMp' k v]
-  deriving (Show)
-
-emptyVarMpStk :: VarMpStk' k v
-emptyVarMpStk = VarMpStk [emptyVarMp]
-
-varmpstkUnit :: Ord k => k -> v -> VarMpStk' k v
-varmpstkUnit k v = VarMpStk [mkVarMp (Map.fromList [(k,v)])]
-
-varmpstkPushEmpty :: VarMpStk' k v -> VarMpStk' k v
-varmpstkPushEmpty (VarMpStk s) = VarMpStk (emptyVarMp : s)
-
-varmpstkPop :: VarMpStk' k v -> (VarMpStk' k v, VarMpStk' k v)
-varmpstkPop (VarMpStk (s:ss)) = (VarMpStk [s], VarMpStk ss)
-varmpstkPop _                 = panic "varmpstkPop: empty"
-
-varmpstkToAssocL :: VarMpStk' k v -> AssocL k v
-varmpstkToAssocL (VarMpStk s) = concatMap varmpToAssocL s
-
-varmpstkKeysSet :: Ord k => VarMpStk' k v -> Set.Set k
-varmpstkKeysSet (VarMpStk s) = Set.unions $ map varmpKeysSet s
-
-varmpstkUnions :: Ord k => [VarMpStk' k v] -> VarMpStk' k v
-varmpstkUnions [x] = x
-varmpstkUnions l   = foldr (|+>) emptyVarMpStk l
-
-instance Ord k => VarLookup (VarMpStk' k v) k v where
-  varlookupWithMetaLev l k (VarMpStk s) = varlookupWithMetaLev l k s
-
-instance Ord k => VarLookupCmb (VarMpStk' k v) (VarMpStk' k v) where
-  (VarMpStk s1) |+> (VarMpStk s2) = VarMpStk (s1 |+> s2)
--}
-
--- Pretty printing
-
-ppVarMpV :: (PP k, PP v) => VarMp' k v -> PP_Doc
-ppVarMpV = ppVarMp vlist
-
-ppVarMp :: (PP k, PP v) => ([PP_Doc] -> PP_Doc) -> VarMp' k v -> PP_Doc
-ppVarMp ppL (VarMp mlev ms)
-  = ppL [ "@" >|< pp lev >|< ":" >#< ppL [ pp n >|< ":->" >|< pp v | (n,v) <- Map.toList m]
-        | (lev,m) <- zip [mlev..] ms
-        ]
-
-instance (PP k, PP v) => PP (VarMp' k v) where
-  pp = ppVarMp (ppCommas')
-
-{-
-instance (PP k, PP v) => PP (VarMpStk' k v) where
-  pp (VarMpStk s) = ppSemis' $ map pp s
--}
-
-{-
-ppVarMpInfoCfgTy :: CfgPPTy -> VarMpInfo -> PP_Doc
-ppVarMpInfoCfgTy c i
-  = case i of
-      VMITy       t -> ppTyWithCfg    c t
-      VMIImpls    i -> ppImplsWithCfg c i
-      VMIScope    s -> pp s                     -- rest incomplete
-      VMIPred     p -> pp p
-      VMILabel    x -> pp x
-      VMIOffset   x -> pp x
-      VMIPredSeq  x -> pp "predseq" -- pp x
-
-ppVarMpInfoDt :: VarMpInfo -> PP_Doc
-ppVarMpInfoDt = ppVarMpInfoCfgTy cfgPPTyDT
-
-instance PP VarMpInfo where
-  pp (VMITy       t) = pp t
-  pp (VMIImpls    i) = pp i
-  pp (VMIScope    s) = pp s
-  pp (VMIPred     p) = pp p
-  pp (VMILabel    x) = pp x
-  pp (VMIOffset   x) = pp x
-  -- pp (VMIExts     x) = pp "exts" -- pp x
-  pp (VMIPredSeq  x) = pp "predseq" -- pp x
-
-instance Serialize VarMpInfo where
-  sput (VMITy      a) = sputWord8 0  >> sput a
-  sput (VMIImpls   a) = sputWord8 1  >> sput a
-  sput (VMIScope   a) = sputWord8 2  >> sput a
-  sput (VMIPred    a) = sputWord8 3  >> sput a
-  sput (VMIAssNm   a) = sputWord8 4  >> sput a
-  sput (VMILabel   a) = sputWord8 5  >> sput a
-  sput (VMIOffset  a) = sputWord8 6  >> sput a
-  sput (VMIPredSeq a) = sputWord8 7  >> sput a
-  sget = do t <- sgetWord8
-            case t of
-              0 -> liftM VMITy      sget
-              1 -> liftM VMIImpls   sget
-              2 -> liftM VMIScope   sget
-              3 -> liftM VMIPred    sget
-              4 -> liftM VMIAssNm   sget
-              5 -> liftM VMILabel   sget
-              6 -> liftM VMIOffset  sget
-              7 -> liftM VMIPredSeq sget
--}
 
 instance (Ord k, Serialize k, Serialize v) => Serialize (VarMp' k v) where
   -- sput (VarMp a b) = sput a >> sput b
diff --git a/src/UHC/Util/VecAlloc.hs b/src/UHC/Util/VecAlloc.hs
new file mode 100644
--- /dev/null
+++ b/src/UHC/Util/VecAlloc.hs
@@ -0,0 +1,13 @@
+
+-------------------------------------------------------------------------------------------
+-- | Vector intended for densily filled entries close to 0, > 0.
+-- In situ updates are not supposed to happen often.
+-------------------------------------------------------------------------------------------
+
+module UHC.Util.VecAlloc
+  ( module CHR.Data.VecAlloc
+  
+  )
+  where
+
+import CHR.Data.VecAlloc
diff --git a/uhc-util.cabal b/uhc-util.cabal
--- a/uhc-util.cabal
+++ b/uhc-util.cabal
@@ -1,12 +1,12 @@
 Name:				uhc-util
-Version:			0.1.6.7
+Version:			0.1.7.0
 cabal-version:      >= 1.6
 License:			BSD3
-Copyright:			Utrecht University, Department of Information and Computing Sciences, Software Technology group
+Copyright:			Atze Dijkstra & Utrecht University, Department of Information and Computing Sciences, Software Technology group
 Build-Type:			Simple
 license-file:		LICENSE 
 Author:				Atze Dijkstra
-Maintainer:         atze@uu.nl
+Maintainer:         atzedijkstra@gmail.com
 Homepage:           https://github.com/UU-ComputerScience/uhc-util
 Bug-Reports:        https://github.com/UU-ComputerScience/uhc-util/issues
 Category:			Development
@@ -21,10 +21,10 @@
 
 library
   Build-Depends:
-    base >= 4.8.1 && < 5,
+    base >= 4.10.1 && < 5,
     mtl >= 2,
     transformers >= 0.4.2,
-    fgl >= 5.4,
+    fgl >= 5.6,
     hashable >= 1.2.4,
     containers >= 0.4,
     directory >= 1.1,
@@ -37,7 +37,12 @@
     time >= 1.2,
     fclabels >= 2.0.3,
     logict-state >= 0.1.0.2,
-    pqueue >= 1.3.1
+    pqueue >= 1.3.1,
+    vector >= 0.11,
+    chr-pretty >= 0.1.0.0,
+    chr-parse >= 0.1.0.0,
+    chr-data >= 0.1.0.0,
+    chr-core >= 0.1.0.0
   Exposed-Modules:
     UHC.Util.AGraph,
     UHC.Util.AssocL,
@@ -45,12 +50,9 @@
     UHC.Util.CHR,
     UHC.Util.CHR.Key,
     UHC.Util.CHR.Base,
+    UHC.Util.CHR.Types,
     UHC.Util.CHR.Rule,
     UHC.Util.CHR.Solve.TreeTrie.Mono,
-    UHC.Util.CHR.Solve.TreeTrie.MonoBacktrackPrio,
-    UHC.Util.CHR.Solve.TreeTrie.Examples.Term.Main,
-    UHC.Util.CHR.Solve.TreeTrie.Visualizer,
-    UHC.Util.CHR.GTerm,
     UHC.Util.CompileRun,
     UHC.Util.CompileRun2,
     UHC.Util.CompileRun3,
@@ -63,11 +65,12 @@
     UHC.Util.Fresh,
     UHC.Util.Hashable,
     UHC.Util.Lens,
+    UHC.Util.Lookup,
+    UHC.Util.Lookup.Stacked,
     UHC.Util.Nm,
     UHC.Util.ParseErrPrettyPrint,
     UHC.Util.ParseUtils,
     UHC.Util.Pretty,
-    UHC.Util.PrettySimple,
     UHC.Util.PrettyUtils,
     UHC.Util.Rel,
     UHC.Util.RelMap,
@@ -80,16 +83,13 @@
     UHC.Util.Substitutable,
     UHC.Util.Time,
     UHC.Util.TreeTrie,
-    UHC.Util.TreeTrie2,
     UHC.Util.Utils,
     UHC.Util.VarLookup,
-    UHC.Util.VarMp
+    UHC.Util.VarMp,
+    UHC.Util.VecAlloc
   Other-Modules:
     UHC.Util.CHR.Solve.TreeTrie.Internal.Shared,
-    UHC.Util.CHR.Solve.TreeTrie.Internal,
-    UHC.Util.CHR.GTerm.AST,
-    UHC.Util.CHR.GTerm.Parser,
-    UHC.Util.CHR.Solve.TreeTrie.Examples.Term.AST
+    UHC.Util.CHR.Solve.TreeTrie.Internal
   Ghc-Options:		
   HS-Source-Dirs: src
   Build-Tools: