uhc-util 0.1.6.7 → 0.1.7.0

raw patch · 32 files changed

+223/−5805 lines, 32 filesdep +chr-coredep +chr-datadep +chr-parsedep ~basedep ~fglPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: chr-core, chr-data, chr-parse, chr-pretty, vector

Dependency ranges changed: base, fgl

API changes (from Hackage documentation)

Files

• changelog.md +10/−0
• src/UHC/Util/AssocL.hs +2/−90
• src/UHC/Util/CHR/Base.hs +23/−369
• src/UHC/Util/CHR/GTerm.hs +0/−14
• src/UHC/Util/CHR/GTerm/AST.hs +0/−85
• src/UHC/Util/CHR/GTerm/Parser.hs +0/−147
• src/UHC/Util/CHR/Key.hs +1/−1
• src/UHC/Util/CHR/Rule.hs +1/−3
• src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/AST.hs +0/−466
• src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/Main.hs +0/−111
• src/UHC/Util/CHR/Solve/TreeTrie/Internal/Shared.hs +20/−14
• src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs +3/−3
• src/UHC/Util/CHR/Solve/TreeTrie/MonoBacktrackPrio.hs +0/−1163
• src/UHC/Util/CHR/Solve/TreeTrie/Visualizer.hs +0/−568
• src/UHC/Util/CHR/Types.hs +31/−0
• src/UHC/Util/DependencyGraph.hs +2/−0
• src/UHC/Util/FastSeq.hs +2/−158
• src/UHC/Util/Fresh.hs +2/−36
• src/UHC/Util/Lens.hs +2/−138
• src/UHC/Util/Lookup.hs +13/−0
• src/UHC/Util/Lookup/Stacked.hs +12/−0
• src/UHC/Util/Pretty.hs +7/−478
• src/UHC/Util/PrettySimple.hs +0/−230
• src/UHC/Util/ScopeVarMp.hs +2/−2
• src/UHC/Util/Serialize.hs +5/−2
• src/UHC/Util/Substitutable.hs +2/−85
• src/UHC/Util/TreeTrie2.hs +0/−825
• src/UHC/Util/Utils.hs +38/−17
• src/UHC/Util/VarLookup.hs +13/−221
• src/UHC/Util/VarMp.hs +2/−562
• src/UHC/Util/VecAlloc.hs +13/−0
• uhc-util.cabal +17/−17

@@ -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

@@ -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

@@ -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--}  

@@ -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--

@@ -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)

@@ -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 ":"--

@@ -11,7 +11,7 @@   )   where -import UHC.Util.TreeTrie+import           UHC.Util.TreeTrie  ------------------------------------------------------------------------------------------- --- TTKeyable

@@ -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 -------------------------------------------------------------------------------------------

@@ -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-

@@ -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'-  --{---}

@@ -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"

@@ -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

@@ -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---}

@@ -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\-       \"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,13 @@+-------------------------------------------------------------------------------------------+-- Abstraction of Map like datatypes providing lookup+-------------------------------------------------------------------------------------------++module UHC.Util.Lookup+  (+    module CHR.Data.Lookup+  )+  where++-------------------------------------------------------------------------------------------+import CHR.Data.Lookup+

@@ -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+

@@ -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-         }

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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]>-  ]---}

@@ -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  $? 

@@ -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 #-}

@@ -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

@@ -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

@@ -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: