uhc-util 0.1.6.5 → 0.1.6.6

raw patch · 36 files changed

+4843/−1588 lines, 36 filesdep +pqueuedep +transformersdep −sybdep ~basedep ~logict-statePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: pqueue, transformers

Dependencies removed: syb

Dependency ranges changed: base, logict-state

API changes (from Hackage documentation)

Files

• changelog.md +6/−0
• src/UHC/Util/AssocL.hs +12/−1
• src/UHC/Util/Binary.hs +5/−4
• src/UHC/Util/CHR/Base.hs +390/−180
• src/UHC/Util/CHR/GTerm.hs +14/−0
• src/UHC/Util/CHR/GTerm/AST.hs +85/−0
• src/UHC/Util/CHR/GTerm/Parser.hs +147/−0
• src/UHC/Util/CHR/Key.hs +1/−0
• src/UHC/Util/CHR/Rule.hs +320/−70
• src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/AST.hs +466/−0
• src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/Main.hs +96/−0
• src/UHC/Util/CHR/Solve/TreeTrie/Internal.hs +23/−94
• src/UHC/Util/CHR/Solve/TreeTrie/Internal/Shared.hs +138/−0
• src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs +89/−76
• src/UHC/Util/CHR/Solve/TreeTrie/MonoBacktrackPrio.hs +1143/−537
• src/UHC/Util/CHR/Solve/TreeTrie/Poly.hs +0/−506
• src/UHC/Util/CompileRun.hs +1/−1
• src/UHC/Util/CompileRun2.hs +1/−1
• src/UHC/Util/CompileRun3.hs +1/−1
• src/UHC/Util/Fresh.hs +44/−0
• src/UHC/Util/Lens.hs +40/−4
• src/UHC/Util/ParseUtils.hs +1/−1
• src/UHC/Util/Pretty.hs +6/−2
• src/UHC/Util/PrettySimple.hs +3/−3
• src/UHC/Util/RLList.hs +1/−1
• src/UHC/Util/RLList/LexScope.hs +4/−0
• src/UHC/Util/ScanUtils.hs +3/−2
• src/UHC/Util/ScopeMapGam.hs +6/−6
• src/UHC/Util/ScopeVarMp.hs +592/−0
• src/UHC/Util/Substitutable.hs +65/−15
• src/UHC/Util/TreeTrie.hs +17/−17
• src/UHC/Util/TreeTrie2.hs +825/−0
• src/UHC/Util/Utils.hs +77/−9
• src/UHC/Util/VarLookup.hs +168/−31
• src/UHC/Util/VarMp.hs +36/−18
• uhc-util.cabal +17/−8

@@ -1,5 +1,11 @@ # Changelog +## 0.1.6.6++- [compatibility] with ghc 8.0.1+- [chr engine] development, examples, debugging, ...+- [libs] removed dependency on syb (and Data instances)+ ## 0.1.6.5  - [libs] updated version lowerbound for hashable and fclabels

@@ -5,7 +5,8 @@     , assocLElts, assocLKeys     , assocLGroupSort     , assocLMapUnzip-    , ppAssocL, ppAssocL', ppAssocLV+    , ppAssocL, ppAssocL'+    , ppAssocLV, ppAssocLH     , ppCurlysAssocL            -- * Utils@@ -16,6 +17,7 @@ import UHC.Util.Utils import Data.List import Data.Maybe+import Data.Function  ------------------------------------------------------------------------------------------- --- AssocL@@ -32,7 +34,12 @@  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)@@ -70,6 +77,8 @@ -- | 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@@ -81,3 +90,5 @@                                      ls                       ) l +-}+{-# INLINE combineToDistinguishedElts #-}

@@ -8,7 +8,7 @@   , module Data.Binary.Put   , module UHC.Util.Control.Monad   , module Data.Typeable-  , module Data.Generics+  -- , module Data.Generics    , hGetBinary   , getBinaryFile@@ -20,13 +20,13 @@    , putEnum, getEnum   , putEnum8, getEnum8-  , putList, getList+  -- , putList, getList   )   where  import qualified Data.ByteString.Lazy as L import Data.Typeable-import Data.Generics (Data)+-- import Data.Generics (Data) import Data.Binary import Data.Binary.Put(runPut,putWord16be) import Data.Binary.Get(runGet,getWord16be)@@ -113,6 +113,7 @@ getEnum8 = do n <- getWord8               return (toEnum $ fromIntegral n) +{- -- | put a [] putList :: (Binary a, Binary b) => (x -> Bool) -> (x -> (a,b)) -> x -> Put putList isNil getCons x | isNil x   = putWord8 0@@ -125,4 +126,4 @@        case tag of          0 -> return nil          1 -> liftM2 cons get get-+-}

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, ExistentialQuantification, ScopedTypeVariables, StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, ExistentialQuantification, ScopedTypeVariables, StandaloneDeriving, GeneralizedNewtypeDeriving, TemplateHaskell, NoMonomorphismRestriction #-}  ------------------------------------------------------------------------------------------- --- Constraint Handling Rules@@ -11,43 +11,262 @@  module UHC.Util.CHR.Base   ( IsConstraint(..)+  , ConstraintSolvesVia(..)    , IsCHRConstraint(..)-  , CHRConstraint(..)+  -- , CHRConstraint(..)      , IsCHRGuard(..)-  , CHRGuard(..)+  -- , CHRGuard(..)   +  -- , IsCHRBuiltin(..)+  -- , CHRBuiltin(..)+     , IsCHRPrio(..)-  , CHRPrio(..)+  -- , CHRPrio(..)   +  , IsCHRBacktrackPrio(..)+     , CHREmptySubstitution(..)-  , CHRMatchable(..), CHRMatchableKey+  +  , CHRMatcherFailure(..)+  +  , CHRMatcher+  , chrmatcherRun'+  , chrmatcherRun+  -- , chrmatcherLift+  -- , chrmatcherUnlift+  +  , chrmatcherstateEnv+  , chrmatcherstateVarLookup+  +  , chrMatchResolveCompareAndContinue+  , chrMatchSubst+  , chrMatchBind+  , chrMatchFail+  , chrMatchFailNoBinding+  , chrMatchSuccess+  , chrMatchWait+  , chrMatchSucces+  -- , chrMatchVarUpd+  +  , CHRMatchEnv(..)+  , emptyCHRMatchEnv+  +  , CHRMatchable(..)+  , CHRMatchableKey+  , CHRMatchHow(..)+  , chrMatchAndWaitToM+  +  , CHRWaitForVarSet+     , CHRCheckable(..)+  +  , Prio(..)   , CHRPrioEvaluatable(..)+  , CHRPrioEvaluatableVal+  +  -- , CHRBuiltinSolvable(..)+  +  , CHRTrOpt(..)   )   where -import qualified UHC.Util.TreeTrie as TreeTrie+-- import qualified UHC.Util.TreeTrie as TreeTrie import           UHC.Util.VarMp+import           Data.Word import           Data.Monoid import           Data.Typeable+import           Data.Function import           Unsafe.Coerce import qualified Data.Set as Set import           UHC.Util.Pretty import           UHC.Util.CHR.Key import           Control.Monad+import           Control.Monad.State.Strict+import           Control.Monad.Except+import           Control.Monad.Identity+import           UHC.Util.Lens import           UHC.Util.Utils import           UHC.Util.Binary import           UHC.Util.Serialize import           UHC.Util.Substitutable +import           UHC.Util.Debug+ ----------------------------------------------------------------------------------------------- Constraint, Guard API+--- 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+-------------------------------------------------------------------------------------------+ -- | (Class alias) API for constraint requirements class ( CHRMatchable env c subst+      -- , CHRBuiltinSolvable env c subst       , VarExtractable c       , VarUpdatable c subst       , Typeable c@@ -58,6 +277,10 @@       , PP c, PP (TTKey c)       ) => IsCHRConstraint env c subst +-------------------------------------------------------------------------------------------+--- Guard API+-------------------------------------------------------------------------------------------+ -- | (Class alias) API for guard requirements class ( CHRCheckable env g subst       , VarExtractable g@@ -67,6 +290,10 @@       , PP g       ) => IsCHRGuard env g subst +-------------------------------------------------------------------------------------------+--- Prio API+-------------------------------------------------------------------------------------------+ -- | (Class alias) API for priority requirements class ( CHRPrioEvaluatable env p subst       , Typeable p@@ -74,232 +301,215 @@       , PP p       ) => IsCHRPrio env p subst -instance {-# OVERLAPPABLE #-} IsCHRPrio env () subst------------------------------------------------------------------------------------------------- Existentially quantified Constraint representations to allow for mix of arbitrary universes----------------------------------------------------------------------------------------------data CHRConstraint env subst-  = forall c . -    ( IsCHRConstraint env c subst-    , TTKey (CHRConstraint env subst) ~ TTKey c-    , ExtrValVarKey (CHRConstraint env subst) ~ ExtrValVarKey c-    )-    => CHRConstraint-         { chrConstraint :: c-         }--deriving instance Typeable (CHRConstraint env subst)--- deriving instance (Data env, Data subst) => Data (CHRConstraint env subst)+-- instance {-# OVERLAPPABLE #-} IsCHRPrio env () subst -instance TTKeyable (CHRConstraint env subst) where-  toTTKey' o (CHRConstraint c) = toTTKey' o c+-- | (Class alias) API for backtrack priority requirements+class ( IsCHRPrio env bp subst+      , CHRMatchable env bp subst+      , PP (CHRPrioEvaluatableVal bp)+      -- , Num (CHRPrioEvaluatableVal bp)+      ) => IsCHRBacktrackPrio env bp subst -instance Show (CHRConstraint env subst) where-  show _ = "CHRConstraint"+-- instance {-# OVERLAPPABLE #-} (CHREmptySubstitution subst, VarLookupCmb subst subst) => IsCHRBacktrackPrio env () subst -instance PP (CHRConstraint env subst) where-  pp (CHRConstraint c) = pp c+-------------------------------------------------------------------------------------------+--- What a constraint must be capable of+------------------------------------------------------------------------------------------- -instance IsConstraint (CHRConstraint env subst) where-  cnstrRequiresSolve (CHRConstraint c) = cnstrRequiresSolve c+-- | 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 Eq (CHRConstraint env subst) where-  CHRConstraint (c1 :: c1) == CHRConstraint c2 = case cast c2 of-    Just (c2' :: c1) -> c1 == c2'-    _                -> False+instance PP ConstraintSolvesVia where+  pp = pp . show -instance Ord (CHRConstraint env subst) where-  CHRConstraint (c1 :: c1) `compare` CHRConstraint (c2 :: c2) = case cast c2 of-    Just (c2' :: c1) -> c1 `compare` c2'-    _                -> typeOf (undefined :: c1) `compare` typeOf (undefined :: c2)+-- | 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 -instance (CHRMatchableKey subst ~ TTKey (CHRConstraint env subst)) => CHRMatchable env (CHRConstraint env subst) subst where-  chrMatchTo env subst c1 c2-    = case (c1, c2) of-        (CHRConstraint (c1' :: c), CHRConstraint c2') -> case cast c2' of-          Just (c2'' :: c) -> chrMatchTo env subst c1' c2''-          _ -> Nothing+-------------------------------------------------------------------------------------------+--- Tracing options, specific for CHR solvers+------------------------------------------------------------------------------------------- -instance (Ord (ExtrValVarKey (CHRConstraint env subst))) => VarExtractable (CHRConstraint env subst) where-  varFreeSet (CHRConstraint c) = varFreeSet c+data CHRTrOpt+  = CHRTrOpt_Lookup     -- ^ trie query+  | CHRTrOpt_Stats      -- ^ various stats+  deriving (Eq, Ord, Show)+-------------------------------------------------------------------------------------------+--- CHREmptySubstitution+------------------------------------------------------------------------------------------- -instance VarUpdatable (CHRConstraint env subst) subst where-  s `varUpd`    CHRConstraint c =  CHRConstraint c'-    where c'        = s `varUpd`    c-  s `varUpdCyc` CHRConstraint c = (CHRConstraint c', cyc)-    where (c', cyc) = s `varUpdCyc` c+-- | Capability to yield an empty substitution.+class CHREmptySubstitution subst where+  chrEmptySubst :: subst  ----------------------------------------------------------------------------------------------- Existentially quantified Guard representations to allow for mix of arbitrary universes+--- CHRMatchable ------------------------------------------------------------------------------------------- -data CHRGuard env subst-  = forall g . -    ( IsCHRGuard env g subst-    , ExtrValVarKey (CHRGuard env subst) ~ ExtrValVarKey g-    )-    => CHRGuard-         { chrGuard :: g-         }+-- | The key of a substitution+type family CHRMatchableKey subst :: * -deriving instance Typeable (CHRGuard env subst)--- deriving instance (Data env, Data subst) => Data (CHRGuard env subst)+type instance CHRMatchableKey (StackedVarLookup subst) = CHRMatchableKey subst -instance Show (CHRGuard env subst) where-  show _ = "CHRGuard"+-- | 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 -instance PP (CHRGuard env subst) where-  pp (CHRGuard c) = pp c+  -- | 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 -instance (Ord (ExtrValVarKey (CHRGuard env subst))) => VarExtractable (CHRGuard env subst) where-  varFreeSet (CHRGuard g) = varFreeSet g+  -- | 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 VarUpdatable (CHRGuard env subst) subst where-  s `varUpd`    CHRGuard g =  CHRGuard g'-    where g'        = s `varUpd`    g-  s `varUpdCyc` CHRGuard g = (CHRGuard g', cyc)-    where (g', cyc) = s `varUpdCyc` g+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 CHRCheckable env (CHRGuard env subst) subst where-  chrCheck env subst (CHRGuard g) = chrCheck env subst g+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  ----------------------------------------------------------------------------------------------- Existentially quantified Prio representations to allow for mix of arbitrary universes+--- CHRMatcher API, part I ------------------------------------------------------------------------------------------- -data CHRPrio env subst-  = forall p . -    ( IsCHRPrio env p subst-    )-    => CHRPrio-         { chrPrio :: p-         }--deriving instance Typeable (CHRPrio env subst)--- deriving instance (Data env, Data subst) => Data (CHRGuard env subst)+-- | 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 -instance Show (CHRPrio env subst) where-  show _ = "CHRPrio"+-- | 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 -instance PP (CHRPrio env subst) where-  pp (CHRPrio c) = pp c+-- | 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]) -{--instance (Ord (ExtrValVarKey (CHRGuard env subst))) => VarExtractable (CHRGuard env subst) where-  varFreeSet (CHRGuard g) = varFreeSet g+-------------------------------------------------------------------------------------------+--- CHRMatcher API, part II+------------------------------------------------------------------------------------------- -instance VarUpdatable (CHRGuard env subst) subst where-  s `varUpd`    CHRGuard g =  CHRGuard g'-    where g'        = s `varUpd`    g-  s `varUpdCyc` CHRGuard g = (CHRGuard g', cyc)-    where (g', cyc) = s `varUpdCyc` g--}+chrMatchSubst :: CHRMatcher subst (StackedVarLookup subst)+chrMatchSubst = getl chrmatcherstateVarLookup+{-# INLINE chrMatchSubst #-} -instance CHRPrioEvaluatable env (CHRPrio env subst) subst where-  chrPrioEval env subst (CHRPrio p) = chrPrioEval env subst p+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 #-} ------------------------------------------------------------------------------------------------ CHREmptySubstitution--------------------------------------------------------------------------------------------+chrMatchWait :: (Ord k, k ~ VarLookupKey subst) => k -> CHRMatcher subst ()+chrMatchWait k = chrMatchModifyWait (Set.insert k)+{-# INLINE chrMatchWait #-} --- | Capability to yield an empty substitution.-class CHREmptySubstitution subst where-  chrEmptySubst :: subst+chrMatchSuccess :: CHRMatcher subst ()+chrMatchSuccess = return ()+{-# INLINE chrMatchSuccess #-} ------------------------------------------------------------------------------------------------ CHRMatchable--------------------------------------------------------------------------------------------+-- | Normal CHRMatcher failure+chrMatchFail :: CHRMatcher subst a+chrMatchFail = throwError CHRMatcherFailure+{-# INLINE chrMatchFail #-} -type family CHRMatchableKey subst :: *+-- | CHRMatcher failure because a variable binding is missing+chrMatchFailNoBinding :: CHRMatcher subst a+chrMatchFailNoBinding = throwError CHRMatcherFailure_NoBinding+{-# INLINE chrMatchFailNoBinding #-} --- | A Matchable participates in the reduction process as a reducable constraint.-class (TTKeyable x, TTKey x ~ CHRMatchableKey subst) => CHRMatchable env x subst where -- skey | subst -> skey where --- | x -> subst env where-  chrMatchTo      :: env -> subst -> x -> x -> Maybe subst+chrMatchSucces :: CHRMatcher subst ()+chrMatchSucces = return ()+{-# INLINE chrMatchSucces #-} ------------------------------------------------------------------------------------------------ CHRCheckable--------------------------------------------------------------------------------------------+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 #-} --- | A Checkable participates in the reduction process as a guard, to be checked.-class CHRCheckable env x subst where-  chrCheck      :: env -> subst -> x -> Maybe subst+-- | 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  ----------------------------------------------------------------------------------------------- CHRPrioEvaluatable+--- CHRMatchable: instances ------------------------------------------------------------------------------------------- --- | A PrioEvaluatable participates in the reduction process to indicate the rule priority, higher prio takes precedence-class CHRPrioEvaluatable env x subst where-  chrPrioEval      :: env -> subst -> x -> Int+-- TBD: move to other file...+instance {-# OVERLAPPABLE #-} Ord (ExtrValVarKey ()) => VarExtractable () where+  varFreeSet _ = Set.empty -instance {-# OVERLAPPABLE #-} CHRPrioEvaluatable env () subst where-  chrPrioEval _ _ _ = minBound+instance {-# OVERLAPPABLE #-} (Ord (ExtrValVarKey ()), CHREmptySubstitution subst, VarLookupCmb subst subst, VarLookupKey subst ~ ExtrValVarKey ()) => CHRMatchable env () subst where+  chrUnifyM _ _ _ _ = chrMatchSuccess  ----------------------------------------------------------------------------------------------- What a constraint must be capable of+--- Prio: instances ------------------------------------------------------------------------------------------- --- | 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+instance Show Prio where+  show = show . unPrio +instance PP Prio where+  pp = pp . unPrio+ ----------------------------------------------------------------------------------------------- Instances: Serialize+--- CHRPrioEvaluatable: instances ------------------------------------------------------------------------------------------- --- Does not work...+type instance CHRPrioEvaluatableVal () = Prio  {--instance (Serialize c, IsCHRConstraint e c s, ExtrValVarKey c ~ ExtrValVarKey (CHRConstraint e s), TTKey c ~ TTKey (CHRConstraint e s)) => Serialize (CHRConstraint e s) where-  sput (CHRConstraint a) = sput a-  -- sget = sgetCHRConstraint (sget :: SGet c)-  sget = liftM CHRConstraint (sget :: SGet c)+instance {-# OVERLAPPABLE #-} Ord x => CHRPrioEvaluatable env x subst where+  -- chrPrioEval _ _ _ = minBound+  chrPrioCompare _ (_,x) (_,y) = compare x y -}  {--instance (Serialize c, IsCHRConstraint e c s, ExtrValVarKey c ~ ExtrValVarKey (CHRConstraint e s), TTKey c ~ TTKey (CHRConstraint e s)) => Serialize (CHRConstraint e s) where-  sput (CHRConstraint a) = sput a-  -- sget = sgetCHRConstraint (sget :: SGet c)-  sget = liftM CHRConstraint (sget :: SGet c)+instance {-# OVERLAPPABLE #-} CHRPrioEvaluatable env () subst where+  chrPrioLift _ = ()+  chrPrioEval _ _ _ = minBound+  chrPrioCompare _ _ _ = EQ -} -{--sgetCHRConstraint-  :: forall e c s .-     ( Serialize c-     , IsCHRConstraint e c s-     , ExtrValVarKey c ~ ExtrValVarKey (CHRConstraint e s)-     , TTKey c ~ TTKey (CHRConstraint e s)-     ) => SGet c -> SGet (CHRConstraint e s)-sgetCHRConstraint sgetc-  = liftM CHRConstraint sgetc--} -{--  = do tr <- (sget :: SGet TypeRep)-       if tr == typeRep (Proxy :: Proxy c)-         then liftM (CHRConstraint . unsafeCoerce) sgetc-         else panic $ "UHC.Util.CHR.Base.sgetCHRConstraint: " ++ show tr ++ " /= " --}-  -{--sputgetCHRConstraint-  :: ( Serialize c-     , IsCHRConstraint e c s-     , ExtrValVarKey c ~ ExtrValVarKey (CHRConstraint e s)-     , TTKey c ~ TTKey (CHRConstraint e s)-     ) => ( c -> SPut-          , SGet c -> SGet (CHRConstraint e s)-          )-sputgetCHRConstraint = (sput, liftM CHRConstraint)-(sputCHRConstraint, sgetCHRConstraint) = sputgetCHRConstraint--}--{--instance Serialize (CHRGuard e s) where-  sput (CHRGuard a) = sput a-  sget = liftM CHRGuard sget--}

@@ -0,0 +1,14 @@+-------------------------------------------------------------------------------------------+--- 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++

@@ -0,0 +1,85 @@+-------------------------------------------------------------------------------------------+--- 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)

@@ -0,0 +1,147 @@+{-# 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 ":"++

@@ -27,6 +27,7 @@ type family TTKey x :: *  type instance TTKey [x] = TTKey x+type instance TTKey (Maybe x) = TTKey x  -- | TreeTrie key construction class TTKeyable x where -- key | x -> key where

@@ -6,27 +6,47 @@ -------------------------------------------------------------------------------------------  {- |-Derived from work by Gerrit vd Geest, but with searching structures for predicates-to avoid explosion of search space during resolution.+The representation of rules, which should allow an implementation of:++"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.Rule-  ( CHRRule(..)+  ( RuleBodyAlt(..)      , Rule(..)+  , ruleBody, ruleBody'+  -- , ruleBodyBuiltin+  , ruleSz   -  , (<==>), (==>), (|>)-  , MkSolverConstraint(..)-  , MkSolverGuard(..)-  , MkSolverPrio(..)+  -- , CHRRule(..)+  +  , (/\)+  , (\/)+  , (\!)+  , (<=>>), (==>>), (<\>>)+  , (<==>), (<=>), (==>), (<\>)+  , (|>), (=|)+  , (=!), (=!!)+  , (=@), (@=)+  +  -- , MkSolverConstraint(..)+  -- , MkSolverGuard(..)+  -- , MkSolverBacktrackPrio(..)+  -- , MkSolverPrio(..)+  -- +  -- , MkRule(mkRule)   )   where -import qualified UHC.Util.TreeTrie as TreeTrie+-- import qualified UHC.Util.TreeTrie as TreeTrie import           UHC.Util.CHR.Base import           UHC.Util.VarMp import           UHC.Util.Utils import           Data.Monoid+import           Data.List as List import           Data.Typeable -- import           Data.Data import qualified Data.Set as Set@@ -38,80 +58,137 @@ import           UHC.Util.Substitutable  ----------------------------------------------------------------------------------------------- Existentially quantified Rule representations to allow for mix of arbitrary universes+--- CHR, derived structures ------------------------------------------------------------------------------------------- -data CHRRule env subst-  = CHRRule-      { chrRule :: Rule (CHRConstraint env subst) (CHRGuard env subst) ()+data RuleBodyAlt cnstr bprio+  = RuleBodyAlt+      { rbodyaltBacktrackPrio       :: !(Maybe bprio)        -- ^ optional backtrack priority, if absent it is inherited from the active backtrack prio+      , rbodyaltBody                :: ![cnstr]             -- ^ body constraints to be dealt with by rules+      -- , rbodyaltBodyBuiltin         :: ![builtin]           -- ^ builtin constraints to be dealt with by builtin solving       }   deriving (Typeable) -type instance TTKey (CHRRule env subst) = TTKey (CHRConstraint env subst)--deriving instance Typeable (CHRRule env subst)--instance Show (CHRRule env subst) where-  show _ = "CHRRule"--instance PP (CHRRule env subst) where-  pp (CHRRule r) = pp r+instance Show (RuleBodyAlt c bp) where+  show _ = "RuleBodyAlt" ------------------------------------------------------------------------------------------------ CHR, derived structures--------------------------------------------------------------------------------------------+instance (PP bp, PP c) => PP (RuleBodyAlt c bp) where+  pp a = ppParens (rbodyaltBacktrackPrio a) >#< ppCommas' (rbodyaltBody a)  -- | A CHR (rule) consist of head (simplification + propagation, boundary indicated by an Int), guard, and a body. All may be empty, but not all at the same time.-data Rule cnstr guard prio+data Rule cnstr guard bprio prio   = Rule-      { ruleHead         :: ![cnstr]-      , ruleSimpSz       :: !Int                -- ^ length of the part of the head which is the simplification part-      , ruleGuard        :: ![guard]            -      , ruleBody         :: ![cnstr]-      , rulePrio         :: !(Maybe prio)       -- ^ optional priority, if absent it is considered the lowest possible+      { ruleHead            :: ![cnstr]+      , ruleSimpSz          :: !Int                -- ^ length of the part of the head which is the simplification part+      , ruleGuard           :: ![guard]    +      , ruleBodyAlts        :: ![RuleBodyAlt cnstr bprio]+      , ruleBacktrackPrio   :: !(Maybe bprio)      -- ^ backtrack priority, should be something which can be substituted with the actual prio, later to be referred to at backtrack prios of alternatives+      , rulePrio            :: !(Maybe prio)       -- ^ rule priority, to choose between rules with equal backtrack priority+      , ruleName            :: (Maybe String)       }   deriving (Typeable) +-- | Backwards compatibility: if only one alternative, extract it, ignore other alts+ruleBody' :: Rule c g bp p -> ([c],[c])+ruleBody' (Rule {ruleBodyAlts = (a:_)}) = (rbodyaltBody a, [])+ruleBody' (Rule {ruleBodyAlts = []   }) = ([], [])++-- | Backwards compatibility: if only one alternative, extract it, ignore other alts+ruleBody :: Rule c g bp p -> [c]+ruleBody = fst . ruleBody'+{-# INLINE ruleBody #-}++{-+-- | Backwards compatibility: if only one alternative, extract it, ignore other alts+ruleBodyBuiltin :: Rule c g bp p -> [b]+ruleBodyBuiltin = snd . ruleBody'+{-# INLINE ruleBodyBuiltin #-}+-}++-- | Total nr of cnstrs in rule+ruleSz :: Rule c g bp p -> Int+ruleSz = length . ruleHead+{-# INLINE ruleSz #-}+ emptyCHRGuard :: [a] emptyCHRGuard = [] -instance Show (Rule c g p) where+instance Show (Rule c g bp p) where   show _ = "Rule" -instance (PP c, PP g, PP p) => PP (Rule c g p) where-  pp chr-    = case chr of-        (Rule h@(_:_)  sz g b p) | sz == 0        -> ppChr ([ppL h, pp  "==>"] ++ ppGB g b)-        (Rule h@(_:_)  sz g b p) | sz == length h -> ppChr ([ppL h, pp "<==>"] ++ ppGB g b)-        (Rule h@(_:_)  sz g b p)                  -> ppChr ([ppL (take sz h), pp "|", ppL (drop sz h), pp "<==>"] ++ ppGB g b)-        (Rule []       _  g b p)                  -> ppChr (ppGB g b)-    where ppGB g@(_:_) b@(_:_) = [ppL g, "|" >#< ppL b]-          ppGB g@(_:_) []      = [ppL g >#< "|"]-          ppGB []      b@(_:_) = [ppL b]-          ppGB []      []      = []-          ppL [x] = pp x-          ppL xs  = ppBracketsCommasBlock xs -- ppParensCommasBlock xs-          ppChr l = vlist l -- ppCurlysBlock+instance (PP c, PP g, PP p, PP bp) => PP (Rule c g bp p) where+  pp chr = ppMbPre (\p -> p >#< "::") rPrio $ ppMbPre (\n -> pp n >#< "@") (ruleName chr) $ base+    where base = case chr of+            Rule {} | ruleSimpSz chr == 0                        -> ppChr ([ppL (ruleHead chr), pp "==>"] ++ ppGB (ruleGuard chr) body)+                    | ruleSimpSz chr == length (ruleHead chr)    -> ppChr ([ppL (ruleHead chr), pp "<=>"] ++ ppGB (ruleGuard chr) body)+                    | length (ruleHead chr) == 0                 -> ppChr (ppGB (ruleGuard chr) body)+                    | otherwise                                  -> ppChr ([ppL (drop (ruleSimpSz chr) (ruleHead chr)), pp "\\", ppL (take (ruleSimpSz chr) (ruleHead chr)), pp "<=>"] ++ ppGB (ruleGuard chr) body)+          rPrio = case (ruleBacktrackPrio chr, rulePrio chr) of+            (Nothing, Nothing) -> Nothing+            (Just bp, Just rp) -> Just $ ppParensCommas [pp bp , pp rp ]+            (Just bp, _      ) -> Just $ ppParensCommas [pp bp , pp "_"]+            (_      , Just rp) -> Just $ ppParensCommas [pp "_", pp rp ]+          body = ppSpaces $ intersperse (pp "\\/") $ map ppAlt $ ruleBodyAlts chr+            where ppAlt a = ppMbPre (\p -> ppParens p >#< "::") (rbodyaltBacktrackPrio a) $ ppL $ map pp (rbodyaltBody a) -- ++ map pp (rbodyaltBodyBuiltin a)+          ppGB g@(_:_) b = [ppL g, "|" >#< b] -- g b = ppListPre (\g -> ppL g >#< "|") g+          ppGB []      b = [b]+          -- ppL [x] = pp x+          ppL xs  = ppCommas' xs -- ppParensCommasBlock xs+          ppChr l = ppSpaces l -- vlist l -- ppCurlysBlock -type instance TTKey (Rule cnstr guard prio) = TTKey cnstr+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 prio) where+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+-------------------------------------------------------------------------------------------++{-+data CHRRule env subst+  = CHRRule+      { chrRule :: Rule (CHRConstraint env subst) (CHRGuard env subst) () ()+      }+  deriving (Typeable)++type instance TTKey (CHRRule env subst) = TTKey (CHRConstraint env subst)++deriving instance Typeable (CHRRule env subst)++instance Show (CHRRule env subst) where+  show _ = "CHRRule"++instance PP (CHRRule env subst) where+  pp (CHRRule r) = pp r+-}++------------------------------------------------------------------------------------------- --- Var instances ------------------------------------------------------------------------------------------- -type instance ExtrValVarKey (Rule c g p) = ExtrValVarKey c+type instance ExtrValVarKey (Rule c g bp p) = ExtrValVarKey c+type instance ExtrValVarKey (RuleBodyAlt c p) = ExtrValVarKey c -instance (VarExtractable c, VarExtractable g, ExtrValVarKey c ~ ExtrValVarKey g) => VarExtractable (Rule c g p) where-  varFreeSet          (Rule {ruleHead=h, ruleGuard=g, ruleBody=b})+-- TBD: should vars be extracted from prio and builtin as well?+instance (VarExtractable c) => VarExtractable (RuleBodyAlt c p) where+  varFreeSet          (RuleBodyAlt {rbodyaltBody=b})+    = Set.unions $ map varFreeSet b++-- TBD: should vars be extracted from prio as well?+instance (VarExtractable c, VarExtractable g, ExtrValVarKey c ~ ExtrValVarKey g) => VarExtractable (Rule c g bp p) where+  varFreeSet          (Rule {ruleHead=h, ruleGuard=g, ruleBodyAlts=b})     = Set.unions $ concat [map varFreeSet h, map varFreeSet g, map varFreeSet b] -instance (VarUpdatable c s, VarUpdatable g s) => VarUpdatable (Rule c g p) s where-  varUpd s r@(Rule {ruleHead=h, ruleGuard=g, ruleBody=b})-    = r {ruleHead = map (varUpd s) h, ruleGuard = map (varUpd s) g, ruleBody = map (varUpd s) b}+instance (VarUpdatable c s, VarUpdatable p s) => VarUpdatable (RuleBodyAlt c p) s where+  varUpd s r@(RuleBodyAlt {rbodyaltBacktrackPrio=p, rbodyaltBody=b})+    = r {rbodyaltBacktrackPrio = fmap (varUpd s) p, rbodyaltBody = map (varUpd s) b} +instance (VarUpdatable c s, VarUpdatable g s, VarUpdatable bp s, VarUpdatable p s) => VarUpdatable (Rule c g bp p) s where+  varUpd s r@(Rule {ruleHead=h, ruleGuard=g, ruleBodyAlts=b})+    = r {ruleHead = map (varUpd s) h, ruleGuard = map (varUpd s) g, ruleBodyAlts = map (varUpd s) b}+ ------------------------------------------------------------------------------------------- --- Construction: Rule -------------------------------------------------------------------------------------------@@ -123,7 +200,8 @@ instance {-# INCOHERENT #-} MkSolverConstraint c c where   toSolverConstraint = id   fromSolverConstraint = Just-  ++{-   instance {-# OVERLAPS #-}          ( IsCHRConstraint e c s          , TTKey (CHRConstraint e s) ~ TTKey c@@ -131,6 +209,7 @@          ) => MkSolverConstraint (CHRConstraint e s) c where   toSolverConstraint = CHRConstraint   fromSolverConstraint (CHRConstraint c) = cast c+-}  class MkSolverGuard g g' where   toSolverGuard :: g' -> g@@ -140,13 +219,34 @@   toSolverGuard = id   fromSolverGuard = Just +{- instance {-# OVERLAPS #-}          ( IsCHRGuard e g s          , ExtrValVarKey (CHRGuard e s) ~ ExtrValVarKey g          ) => MkSolverGuard (CHRGuard e s) g where   toSolverGuard = CHRGuard   fromSolverGuard (CHRGuard g) = cast g+-} +{-+class MkSolverBuiltin b b' where+  toSolverBuiltin :: b' -> b+  fromSolverBuiltin :: b -> Maybe b'++instance {-# INCOHERENT #-} MkSolverBuiltin b b where+  toSolverBuiltin = id+  fromSolverBuiltin = Just+-}++{-+instance {-# OVERLAPS #-}+         ( IsCHRBuiltin e b s+         -- , ExtrValVarKey (CHRBuiltin e s) ~ ExtrValVarKey b+         ) => MkSolverBuiltin (CHRBuiltin e s) b where+  toSolverBuiltin = CHRBuiltin+  fromSolverBuiltin (CHRBuiltin b) = cast b+-}+ class MkSolverPrio p p' where   toSolverPrio :: p' -> p   fromSolverPrio :: p -> Maybe p'@@ -155,57 +255,207 @@   toSolverPrio = id   fromSolverPrio = Just +{- instance {-# OVERLAPS #-}          ( IsCHRPrio e p s          -- , ExtrValVarKey (CHRPrio e s) ~ ExtrValVarKey p          ) => MkSolverPrio (CHRPrio e s) p where   toSolverPrio = CHRPrio   fromSolverPrio (CHRPrio p) = cast p+-} +class MkSolverBacktrackPrio p p' where+  toSolverBacktrackPrio :: p' -> p+  fromSolverBacktrackPrio :: p -> Maybe p'++instance {-# INCOHERENT #-} MkSolverBacktrackPrio p p where+  toSolverBacktrackPrio = id+  fromSolverBacktrackPrio = Just++{- class MkRule r where   type SolverConstraint r :: *   type SolverGuard r :: *+  type SolverBacktrackPrio r :: *   type SolverPrio r :: *   -- | Make rule-  mkRule :: [SolverConstraint r] -> Int -> [SolverGuard r] -> [SolverConstraint r] -> Maybe (SolverPrio r) -> r+  mkRule :: [SolverConstraint r] -> Int -> [SolverGuard r] -> [SolverConstraint r] -> [SolverConstraint r] -> Maybe (SolverPrio r) -> r   -- | Add guards to rule   guardRule :: [SolverGuard r] -> r -> r   -- | Add prio to rule   prioritizeRule :: SolverPrio r -> r -> r+  -- | Add backtrack prio to rule+  prioritizeBacktrackRule :: SolverBacktrackPrio r -> r -> r+  -- | Add label/name to rule+  labelRule :: String -> r -> r -instance MkRule (Rule c g p) where-  type SolverConstraint (Rule c g p) = c-  type SolverGuard (Rule c g p) = g-  type SolverPrio (Rule c g p) = p-  mkRule = Rule+instance MkRule (Rule c g bp p) where+  type SolverConstraint (Rule c g bp p) = c+  type SolverGuard (Rule c g bp p) = g+  type SolverBacktrackPrio (Rule c g bp p) = bp+  type SolverPrio (Rule c g bp p) = p+  mkRule h l g b bi p = Rule h l g [RuleBodyAlt Nothing b] Nothing p Nothing   guardRule g r = r {ruleGuard = ruleGuard r ++ g}   prioritizeRule p r = r {rulePrio = Just p}+  prioritizeBacktrackRule p r = r {ruleBacktrackPrio = Just p}+  labelRule l r = r {ruleName = Just l}+-} +mkRule h l g b bi p = Rule h l g [RuleBodyAlt Nothing b] Nothing p Nothing+guardRule g r = r {ruleGuard = ruleGuard r ++ g}+prioritizeRule p r = r {rulePrio = Just p}+prioritizeBacktrackRule p r = r {ruleBacktrackPrio = Just p}+labelRule l r = r {ruleName = Just l}++{- instance MkRule (CHRRule e s) where   type SolverConstraint (CHRRule e s) = (CHRConstraint e s)   type SolverGuard (CHRRule e s) = (CHRGuard e s)+  type SolverBuiltin (CHRRule e s) = ()   type SolverPrio (CHRRule e s) = ()-  mkRule h1 h2 l b p = CHRRule $ mkRule h1 h2 l b p+  mkRule h l g b bi p = CHRRule $ mkRule h l g b bi p   guardRule g (CHRRule r) = CHRRule $ guardRule g r   prioritizeRule p (CHRRule r) = CHRRule $ prioritizeRule p r+  prioritizeBacktrackRule p (CHRRule r) = CHRRule $ prioritizeBacktrackRule p r+  labelRule p (CHRRule r) = CHRRule $ labelRule p r+-} -infix   1 <==>, ==>-infixr  0 |>+infixl  6 /\+infixl  5 \!+infixr  4 \/+infix   3 <==>, <=>, ==>, <\>+infixl  2 |>, =|+infixl  2 =!, =!!+infixl  2 =@+infixr  1 @= -(<==>), (==>) :: forall r c1 c2 . (MkRule r, MkSolverConstraint (SolverConstraint r) c1, MkSolverConstraint (SolverConstraint r) c2) => [c1] -> [c2] -> r-hs <==>  bs = mkRule (map toSolverConstraint hs) (length hs) [] (map toSolverConstraint bs) Nothing-hs  ==>  bs = mkRule (map toSolverConstraint hs) 0 [] (map toSolverConstraint bs) Nothing+-- | Rule body backtracking alternative+(/\) :: [c] -> [c] -> RuleBodyAlt c p+c /\ b = RuleBodyAlt Nothing (c ++ b) -(|>) :: (MkRule r, MkSolverGuard (SolverGuard r) g') => r -> [g'] -> r+-- | Rule body backtracking alternatives+(\/) :: [RuleBodyAlt c p] -> [RuleBodyAlt c p] -> [RuleBodyAlt c p]+(\/) = (++)++-- | Add backtrack priority to body alternative+(\!) :: RuleBodyAlt c p -> p -> RuleBodyAlt c p+r \! p = r {rbodyaltBacktrackPrio = Just p}++{-+(<=>>), (==>>) :: forall r c1 c2 c3 . (MkRule r, MkSolverConstraint (SolverConstraint r) c1, MkSolverConstraint (SolverConstraint r) c2, MkSolverConstraint (SolverConstraint r) c3)+  => [c1] -> ([c2], [c3]) -> r+-- | Construct simplification rule out of head, body, and builtin constraints+hs <=>>  (bs,bis) = mkRule (map toSolverConstraint hs) (length hs) [] (map toSolverConstraint bs) (map toSolverConstraint bis) Nothing+-- | Construct propagation rule out of head, body, and builtin constraints+hs  ==>>  (bs,bis) = mkRule (map toSolverConstraint hs) 0 [] (map toSolverConstraint bs) (map toSolverConstraint bis) Nothing+-}++-- | Construct simplification rule out of head, body, and builtin constraints+hs <=>>  (bs,bis) = mkRule hs (length hs) [] bs bis Nothing+-- | Construct propagation rule out of head, body, and builtin constraints+hs  ==>>  (bs,bis) = mkRule hs 0 [] bs bis Nothing++{-+(<\>>) :: forall r c1 c2 c3 . (MkRule r, MkSolverConstraint (SolverConstraint r) c1, MkSolverConstraint (SolverConstraint r) c2, MkSolverConstraint (SolverConstraint r) c3)+  => ([c1],[c1]) -> ([c2],[c3]) -> r+-- | Construct simpagation rule out of head, body, and builtin constraints+(hsprop,hssimp) <\>>  (bs,bis) = mkRule (map toSolverConstraint $ hssimp ++ hsprop) (length hssimp) [] (map toSolverConstraint bs) (map toSolverConstraint bis) Nothing+-}++-- | Construct simpagation rule out of head, body, and builtin constraints+(hsprop,hssimp) <\>>  (bs,bis) = mkRule (hssimp ++ hsprop) (length hssimp) [] (bs) (bis) Nothing++{-+{-# DEPRECATED (<==>) "Use (<=>)" #-}+(<==>), (==>), (<=>) :: forall r c1 c2 . (MkRule r, MkSolverConstraint (SolverConstraint r) c1, MkSolverConstraint (SolverConstraint r) c2)+  => [c1] -> [c2] -> r+-- | Construct simplification rule out of head and body constraints+hs <==>  bs = mkRule (map toSolverConstraint hs) (length hs) [] (map toSolverConstraint bs) [] Nothing+-- | Construct propagation rule out of head and body constraints+hs  ==>  bs = mkRule (map toSolverConstraint hs) 0 [] (map toSolverConstraint bs) [] Nothing+(<=>) = (<==>)+-}++-- | Construct simplification rule out of head and body constraints+hs <==>  bs = mkRule (hs) (length hs) [] (bs) [] Nothing+-- | Construct propagation rule out of head and body constraints+hs  ==>  bs = mkRule (hs) 0 [] (bs) [] Nothing+(<=>) = (<==>)++{-+(<\>) :: forall r c1 c2 . (MkRule r, MkSolverConstraint (SolverConstraint r) c1, MkSolverConstraint (SolverConstraint r) c2)+  => ([c1],[c1]) -> [c2] -> r+-- | Construct simpagation rule out of head and body constraints+(hsprop,hssimp) <\>  bs = mkRule (map toSolverConstraint $ hssimp ++ hsprop) (length hssimp) [] (map toSolverConstraint bs) [] Nothing+-}++-- | Construct simpagation rule out of head and body constraints+(hsprop,hssimp) <\>  bs = mkRule (hssimp ++ hsprop) (length hssimp) [] (bs) [] Nothing++{-+{-# DEPRECATED (|>) "Use (=|)" #-}+-- | Add guards to rule+(|>), (=|) :: (MkRule r, MkSolverGuard (SolverGuard r) g') => r -> [g'] -> r r |> g = guardRule (map toSolverGuard g) r+(=|) = (|>)+{-# INLINE (=|) #-}+-} +{-# DEPRECATED (|>) "Use (=|)" #-}+-- | Add guards to rule+r |> g = guardRule (g) r+(=|) = (|>)+{-# INLINE (=|) #-}++{-+-- | Add priority to rule+(=!!) :: (MkRule r, MkSolverPrio (SolverPrio r) p') => r -> p' -> r+r =!! p = prioritizeRule (toSolverPrio p) r+-}++-- | Add priority to rule+r =!! p = prioritizeRule (p) r++{-+-- | Add backtrack priority to rule+(=!) :: (MkRule r, MkSolverBacktrackPrio (SolverBacktrackPrio r) p') => r -> p' -> r+r =! p = prioritizeBacktrackRule (toSolverBacktrackPrio p) r+-}++-- | Add backtrack priority to rule+r =! p = prioritizeBacktrackRule (p) r++{-+-- | Add label to rule+(=@) :: (MkRule r) => r -> String -> r+r =@ l = labelRule l r+-}++-- | Add label to rule+r =@ l = labelRule l r++{-+-- | Add label to rule+(@=) :: (MkRule r) => String -> r -> r+l @= r = r =@ l+{-# INLINE (@=) #-}+-}++-- | Add label to rule+l @= r = r =@ l+{-# INLINE (@=) #-}+ ------------------------------------------------------------------------------------------- --- Instances: Serialize ------------------------------------------------------------------------------------------- -instance (Serialize c,Serialize g,Serialize p) => Serialize (Rule c g p) where-  sput (Rule a b c d e) = sput a >> sput b >> sput c >> sput d >> sput e-  sget = liftM5 Rule sget sget sget sget sget+instance (Serialize c,Serialize p) => Serialize (RuleBodyAlt c p) where+  sput (RuleBodyAlt a b) = sput a >> sput b+  sget = liftM2 RuleBodyAlt sget sget++instance (Serialize c,Serialize g,Serialize bp,Serialize p) => Serialize (Rule c g bp p) where+  sput (Rule a b c d e f g) = sput a >> sput b >> sput c >> sput d >> sput e >> sput f >> sput g+  sget = liftM7 Rule sget sget sget sget sget sget sget  {- instance (MkSolverConstraint (CHRConstraint e s) x', Serialize x') => Serialize (CHRConstraint e s) where

@@ -0,0 +1,466 @@+{-# 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+

@@ -0,0 +1,96 @@+module UHC.Util.CHR.Solve.TreeTrie.Examples.Term.Main+  ( RunOpt(..)+  , Verbosity(..)++  , runFile+  )+  where++import           Data.Maybe+import           System.IO+import           Control.Monad+import           Control.Monad.IO.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++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_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+              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'+  ++{-+-}

@@ -6,7 +6,6 @@  module UHC.Util.CHR.Solve.TreeTrie.Internal   ( CHRTrie-  , CHRTrieKey   , CHRLookupHow      , chrLookupHowExact@@ -15,8 +14,7 @@      , emptyCHRTrie   -  , chrToKey-  , chrToWorkKey+  , chrTrieSingleton   , chrTrieDeleteListByKey   , chrTrieElems   , chrTrieFromListByKeyWith@@ -26,19 +24,12 @@   , chrTrieUnion   , chrTrieUnionWith -  , CHRKey   , UsedByKey   , ppUsedByKey   -  , WorkTime-  , initWorkTime-  -  , WorkKey   , WorkUsedInMap   , WorkTrie -  , Work(..)-     , WorkList(..)   , emptyWorkList   , wlUsedInUnion@@ -58,10 +49,7 @@   , lqSingleton   , lqLookupW   , lqLookupC-  -  , SolveStep'(..)-  , SolveTrace'-  , ppSolveTrace+  , ppLastQuery      , SolveState'(..)   , emptySolveState@@ -73,6 +61,7 @@   , slvCombine      , module UHC.Util.CHR.Rule+  , module UHC.Util.CHR.Solve.TreeTrie.Internal.Shared   )   where @@ -80,6 +69,7 @@ import           UHC.Util.CHR.Key import           UHC.Util.CHR.Rule -- import           UHC.Util.CHR.Constraint.UHC+import           UHC.Util.CHR.Solve.TreeTrie.Internal.Shared import           UHC.Util.Substitutable import           UHC.Util.VarLookup import           UHC.Util.VarMp@@ -101,8 +91,7 @@ --- Choice of Trie structure ------------------------------------------------------------------------------------------- -type CHRTrie v = TreeTrie.TreeTrie (TTKey v) v-type CHRTrieKey v = TreeTrie.TreeTrieKey (TTKey v)+type CHRTrie v = CHRTrie' v v type CHRLookupHow = TreeTrieLookup  chrLookupHowExact      = TTL_Exact@@ -111,6 +100,10 @@  emptyCHRTrie = TreeTrie.empty +chrTrieSingleton :: (Ord (TTKey v)) => CHRTrieKey v -> v -> CHRTrie v+chrTrieSingleton = TreeTrie.singleton+{-# INLINE chrTrieSingleton #-}+ chrTrieFromListByKeyWith :: (Ord (TTKey v)) => (v -> v -> v) -> [(CHRTrieKey v,v)] -> CHRTrie v chrTrieFromListByKeyWith = TreeTrie.fromListByKeyWith {-# INLINE chrTrieFromListByKeyWith #-}@@ -139,28 +132,20 @@ chrTrieFromListPartialExactWith = TreeTrie.fromListByKeyWith {-# INLINE chrTrieFromListPartialExactWith #-} +{- chrTrieLookup' :: (Ord (TTKey v), PP (TTKey v)) => (CHRTrieKey v -> v -> v') -> CHRLookupHow -> CHRTrieKey v -> CHRTrie v -> ([v'],Maybe v') chrTrieLookup' = TreeTrie.lookupPartialByKey' {-# INLINE chrTrieLookup' #-}+-}  chrTrieLookup :: (Ord (TTKey v), PP (TTKey v)) => CHRLookupHow -> CHRTrieKey v -> CHRTrie v -> ([v],Maybe v) chrTrieLookup = TreeTrie.lookupPartialByKey {-# INLINE chrTrieLookup #-} -chrToKey :: (TTKeyable x, TrTrKey x ~ TTKey x) => x -> CHRTrieKey x-chrToKey = ttkFixate . toTTKey-{-# INLINE chrToKey #-}--chrToWorkKey :: (TTKeyable x) => x -> CHRTrieKey x-chrToWorkKey = ttkFixate . toTTKey' (defaultTTKeyableOpts {ttkoptsVarsAsWild = False})-{-# INLINE chrToWorkKey #-}- ------------------------------------------------------------------------------------------- --- CHR store, with fast search ------------------------------------------------------------------------------------------- --- type CHRKey = CHRTrieKey-type CHRKey v = CHRTrieKey v type UsedByKey v = (CHRKey v,Int)  -- ppUsedByKey :: UsedByKey v -> PP_Doc@@ -183,7 +168,7 @@  type instance TTKey (StoredCHR c g) = TTKey c -instance (TTKeyable (Rule c g p)) => TTKeyable (StoredCHR c g) where+instance (TTKeyable (Rule c g () ())) => TTKeyable (StoredCHR c g) where   toTTKey' o schr = toTTKey' o $ storedChr schr  -- | The size of the simplification part of a CHR@@ -229,7 +214,7 @@   pp = ppStoredCHR  -- | Convert from list to store-chrStoreFromElems :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => [Rule c g p] -> CHRStore c g p+chrStoreFromElems :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => [Rule c g () ()] -> CHRStore c g chrStoreFromElems chrs   = mkCHRStore     $ chrTrieFromListByKeyWith cmbStoredCHRs@@ -243,20 +228,20 @@               ks' = map Just ks1 ++ [Nothing] ++ map Just ks2         ] -chrStoreSingletonElem :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => Rule c g p -> CHRStore c g p+chrStoreSingletonElem :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => Rule c g () () -> CHRStore c g chrStoreSingletonElem x = chrStoreFromElems [x] -chrStoreUnion :: (Ord (TTKey c)) => CHRStore c g p -> CHRStore c g p -> CHRStore c g p+chrStoreUnion :: (Ord (TTKey c)) => CHRStore c g -> CHRStore c g -> CHRStore c g chrStoreUnion cs1 cs2 = mkCHRStore $ chrTrieUnionWith cmbStoredCHRs (chrstoreTrie cs1) (chrstoreTrie cs2) {-# INLINE chrStoreUnion #-} -chrStoreUnions :: (Ord (TTKey c)) => [CHRStore c g p] -> CHRStore c g p+chrStoreUnions :: (Ord (TTKey c)) => [CHRStore c g] -> CHRStore c g chrStoreUnions []  = emptyCHRStore chrStoreUnions [s] = s chrStoreUnions ss  = foldr1 chrStoreUnion ss {-# INLINE chrStoreUnions #-} -chrStoreToList :: (Ord (TTKey c)) => CHRStore c g p -> [(CHRKey c,[Rule c g p])]+chrStoreToList :: (Ord (TTKey c)) => CHRStore c g -> [(CHRKey c,[Rule c g () ()])] chrStoreToList cs   = [ (k,chrs)     | (k,e) <- chrTrieToListByKey $ chrstoreTrie cs@@ -264,46 +249,25 @@     , not $ Prelude.null chrs     ] -chrStoreElems :: (Ord (TTKey c)) => CHRStore c g p -> [Rule c g p]+chrStoreElems :: (Ord (TTKey c)) => CHRStore c g -> [Rule c g () ()] chrStoreElems = concatMap snd . chrStoreToList -ppCHRStore :: (PP c, PP g, Ord (TTKey c), PP (TTKey c)) => CHRStore c g p -> PP_Doc+ppCHRStore :: (PP c, PP g, Ord (TTKey c), PP (TTKey c)) => CHRStore c g -> PP_Doc ppCHRStore = ppCurlysCommasBlock . map (\(k,v) -> ppTreeTrieKey k >-< indent 2 (":" >#< ppBracketsCommasBlock v)) . chrStoreToList -ppCHRStore' :: (PP c, PP g, Ord (TTKey c), PP (TTKey c)) => CHRStore c g p -> PP_Doc+ppCHRStore' :: (PP c, PP g, Ord (TTKey c), PP (TTKey c)) => CHRStore c g -> PP_Doc ppCHRStore' = ppCurlysCommasBlock . map (\(k,v) -> ppTreeTrieKey k >-< indent 2 (":" >#< ppBracketsCommasBlock v)) . chrTrieToListByKey . chrstoreTrie  -}  ----------------------------------------------------------------------------------------------- WorkTime, the time/history counter----------------------------------------------------------------------------------------------type WorkTime = Int--initWorkTime :: WorkTime-initWorkTime = 0--------------------------------------------------------------------------------------------- --- Solver worklist -------------------------------------------------------------------------------------------  -type WorkKey       v = CHRKey v type WorkUsedInMap v = Map.Map (Set.Set (CHRKey v)) (Set.Set (UsedByKey v)) type WorkTrie      c = CHRTrie (Work c) --- | A chunk of work to do when solving, a constraint + sequence nr-data Work c-  = Work-      { workKey     :: WorkKey c-      , workCnstr   :: !c            -- the constraint to be reduced-      , workTime    :: WorkTime                     -- the history count at which the work was added-      -- , workUsedIn  :: Set.Set (CHRKey c)              -- marked with the propagation rules already applied to it-      }--type instance TTKey (Work c) = TTKey c- -- | The work to be done (wlQueue), also represented as a trie (wlTrie) because efficient check on already worked on is needed. --   A done set (wlDoneSet) remembers which CHRs (itself a list of constraints) have been solved. --   To prevent duplicate propagation a mapping from CHRs to a map (wlUsedIn) to the CHRs it is used in is maintained.@@ -322,14 +286,8 @@ wlUsedInUnion = Map.unionWith Set.union {-# INLINE wlUsedInUnion #-} -instance Show (Work c) where-  show _ = "SolveWork" -instance (PP c) => PP (Work c) where-  pp w = pp $ workCnstr w -- wlToList :: {- (PP p, PP i) => -} WorkList c -> [c] wlToList wl = map workCnstr $ chrTrieElems $ wlTrie wl @@ -382,6 +340,9 @@ type LastQueryW v = Map.Map (WorkKey v) WorkTime type LastQuery v = Map.Map (CHRKey v) (LastQueryW v) +ppLastQueryW = ppAssocL . Map.toList+ppLastQuery = ppAssocL . assocLMapElt ppLastQueryW . Map.toList+ -- emptyLastQuery :: LastQuery v emptyLastQuery = Map.empty {-# INLINE emptyLastQuery #-}@@ -401,38 +362,6 @@ -- lqLookupW :: WorkKey v -> LastQueryW v -> WorkTime lqLookupW = Map.findWithDefault initWorkTime {-# INLINE lqLookupW #-}------------------------------------------------------------------------------------------------- Solver trace------------------------------------------------------------------------------------------------ | A trace step-data SolveStep' c r s-  = SolveStep-      { stepChr         :: r-      , stepSubst       :: s-      , stepNewTodo     :: [c]-      , stepNewDone     :: [c]-      }-  | SolveStats-      { stepStats       :: Map.Map String PP_Doc-      }-  | SolveDbg-      { stepPP          :: PP_Doc-      }--type SolveTrace' c r s = [SolveStep' c r s]--instance Show (SolveStep' c r s) where-  show _ = "SolveStep"--instance (PP r, PP c) => {- (PP c, PP g) => -} PP (SolveStep' c r s) where-  pp (SolveStep   step _ todo done) = "STEP" >#< (step >-< "new todo:" >#< ppBracketsCommas todo >-< "new done:" >#< ppBracketsCommas done)-  pp (SolveStats  stats           ) = "STATS"  >#< (ppAssocLV (Map.toList stats))-  pp (SolveDbg    p               ) = "DBG"  >#< p--ppSolveTrace :: (PP r, PP c) => {- (PP s, PP c, PP g) => -} SolveTrace' c r s -> PP_Doc-ppSolveTrace tr = ppBracketsCommasBlock [ pp st | st <- tr ]  ------------------------------------------------------------------------------------------- --- Solve state

@@ -0,0 +1,138 @@+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, UndecidableInstances, NoMonomorphismRestriction, MultiParamTypeClasses #-}++-------------------------------------------------------------------------------------------+-- | CHR TreeTrie based solver shared internals, for all solvers+-------------------------------------------------------------------------------------------++module UHC.Util.CHR.Solve.TreeTrie.Internal.Shared+  ( CHRTrie'+  , CHRTrieKey++  , chrToKey+  , chrToWorkKey++  , CHRKey++  , WorkTime+  , initWorkTime+  +  , WorkKey+  , Work(..)+  +  , SolveStep'(..)+  , SolveTrace'+  , emptySolveTrace+  , ppSolveTrace+  +  )+  where++import           UHC.Util.CHR.Key+import           UHC.Util.TreeTrie as TreeTrie++import           UHC.Util.Pretty as Pretty+import           UHC.Util.AssocL++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)++-- | Obtain key for use in rule+chrToKey :: (TTKeyable x, TrTrKey x ~ TTKey x) => x -> CHRTrieKey x+chrToKey = ttkFixate . toTTKey+{-# INLINE chrToKey #-}++-- | Obtain key for use in to be solved context (i.e. work)+chrToWorkKey :: (TTKeyable x) => x -> CHRTrieKey x+chrToWorkKey = ttkFixate . toTTKey' (defaultTTKeyableOpts {ttkoptsVarsAsWild = False})+{-# INLINE chrToWorkKey #-}++-------------------------------------------------------------------------------------------+--- CHR key+-------------------------------------------------------------------------------------------++-- | Convenience alias for key into CHR store+type CHRKey v = CHRTrieKey v++-------------------------------------------------------------------------------------------+--- WorkTime, the time/history counter for solver work+-------------------------------------------------------------------------------------------++-- | All solver constraints are identified individually with a timestamp, also serving as its identification depending on the solver+type WorkTime = Int++initWorkTime :: WorkTime+initWorkTime = 0++-------------------------------------------------------------------------------------------+--- Solver work and/or residual (non)work+-------------------------------------------------------------------------------------------++type WorkKey       v = CHRKey v++-- | A chunk of work to do when solving, a constraint + sequence nr+data Work c+  = Work+      { workKey     :: WorkKey c                    -- ^ the key into the CHR store+      , workCnstr   :: !c                           -- ^ the constraint to be reduced+      , workTime    :: WorkTime                     -- ^ the timestamp identification at which the work was added+      }+  | Work_Residue+      { workCnstr   :: !c                           -- ^ the residual constraint+      }+  | Work_Solve+      { workCnstr   :: !c                           -- ^ constraint which must be solved+      }+  | Work_Fail++type instance TTKey (Work c) = TTKey c++instance Show (Work c) where+  show _ = "SolveWork"++instance (PP (TTKey c), PP c) => PP (Work c) where+  pp (Work         k c t) = ppParens k >|< "@" >|< t >#< c+  pp (Work_Residue   c  ) = pp                           c+  pp (Work_Solve     c  ) = pp                           c+  pp (Work_Fail         ) = pp "fail"++-------------------------------------------------------------------------------------------+--- Solver trace+-------------------------------------------------------------------------------------------++-- | A trace step+data SolveStep' c r s+  = SolveStep+      { stepChr         :: r+      , stepSubst       :: s+      , stepNewTodo     :: [c]+      , stepNewDone     :: [c]+      }+  | SolveStats+      { stepStats       :: Map.Map String PP_Doc+      }+  | SolveDbg+      { stepPP          :: PP_Doc+      }++type SolveTrace' c r s = [SolveStep' c r s]++emptySolveTrace :: SolveTrace' c r s+emptySolveTrace = []++instance Show (SolveStep' c r s) where+  show _ = "SolveStep"++instance (PP r, PP c) => {- (PP c, PP g) => -} PP (SolveStep' c r s) where+  pp (SolveStep   step _ todo done) = "STEP" >#< (step >-< "new todo:" >#< ppBracketsCommas todo >-< "new done:" >#< ppBracketsCommas done)+  pp (SolveStats  stats           ) = "STATS"  >#< (ppAssocLV (Map.toList stats))+  pp (SolveDbg    p               ) = "DBG"  >#< p++ppSolveTrace :: (PP r, PP c) => {- (PP s, PP c, PP g) => -} SolveTrace' c r s -> PP_Doc+ppSolveTrace tr = ppBracketsCommasBlock [ pp st | st <- tr ]+

@@ -71,51 +71,47 @@ -------------------------------------------------------------------------------------------  -- | A CHR as stored in a CHRStore, requiring additional info for efficiency-data StoredCHR c g p+data StoredCHR c g   = StoredCHR-      { storedChr       :: !(Rule c g p)      -- the Rule+      { storedChr       :: !(Rule c g () ())      -- the Rule       , storedKeyedInx  :: !Int                             -- index of constraint for which is keyed into store       , storedKeys      :: ![Maybe (CHRKey c)]                  -- keys of all constraints; at storedKeyedInx: Nothing       , storedIdent     :: !(UsedByKey c)                       -- the identification of a CHR, used for propagation rules (see remark at begin)       }   deriving (Typeable) --- deriving instance (Data (TTKey c), Data c, Data g) => Data (StoredCHR c g p)--type instance TTKey (StoredCHR c g p) = TTKey c+type instance TTKey (StoredCHR c g) = TTKey c -instance (TTKeyable (Rule c g p)) => TTKeyable (StoredCHR c g p) where+instance (TTKeyable (Rule c g () ())) => TTKeyable (StoredCHR c g) where   toTTKey' o schr = toTTKey' o $ storedChr schr  -- | The size of the simplification part of a CHR-storedSimpSz :: StoredCHR c g p -> Int+storedSimpSz :: StoredCHR c g -> Int storedSimpSz = ruleSimpSz . storedChr {-# INLINE storedSimpSz #-}  -- | A CHR store is a trie structure-newtype CHRStore cnstr guard prio+newtype CHRStore cnstr guard   = CHRStore-      { chrstoreTrie    :: CHRTrie [StoredCHR cnstr guard prio]+      { chrstoreTrie    :: CHRTrie [StoredCHR cnstr guard]       }   deriving (Typeable) --- deriving instance (Data (TTKey cnstr), Ord (TTKey cnstr), Data cnstr, Data guard) => Data (CHRStore cnstr guard prio)- mkCHRStore trie = CHRStore trie -emptyCHRStore :: CHRStore cnstr guard prio+emptyCHRStore :: CHRStore cnstr guard emptyCHRStore = mkCHRStore emptyCHRTrie  -- | Combine lists of stored CHRs by concat, adapting their identification nr to be unique-cmbStoredCHRs :: [StoredCHR c g p] -> [StoredCHR c g p] -> [StoredCHR c g p]+cmbStoredCHRs :: [StoredCHR c g] -> [StoredCHR c g] -> [StoredCHR c g] 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 p) where+instance Show (StoredCHR c g) where   show _ = "StoredCHR" -ppStoredCHR :: (PP (TTKey c), PP c, PP g, PP p) => StoredCHR c g p -> PP_Doc+ppStoredCHR :: (PP (TTKey c), PP c, PP g) => StoredCHR c g -> PP_Doc ppStoredCHR c@(StoredCHR {storedIdent=(idKey,idSeqNr)})   = storedChr c     >-< indent 2@@ -126,11 +122,11 @@             , "ident" >#< ppParensCommas [ppTreeTrieKey idKey,pp idSeqNr]             ]) -instance (PP (TTKey c), PP c, PP g, PP p) => PP (StoredCHR c g p) where+instance (PP (TTKey c), PP c, PP g) => PP (StoredCHR c g) where   pp = ppStoredCHR  -- | Convert from list to store-chrStoreFromElems :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => [Rule c g p] -> CHRStore c g p+chrStoreFromElems :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => [Rule c g () ()] -> CHRStore c g chrStoreFromElems chrs   = mkCHRStore     $ chrTrieFromListByKeyWith cmbStoredCHRs@@ -144,20 +140,20 @@               ks' = map Just ks1 ++ [Nothing] ++ map Just ks2         ] -chrStoreSingletonElem :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => Rule c g p -> CHRStore c g p+chrStoreSingletonElem :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => Rule c g () () -> CHRStore c g chrStoreSingletonElem x = chrStoreFromElems [x] -chrStoreUnion :: (Ord (TTKey c)) => CHRStore c g p -> CHRStore c g p -> CHRStore c g p+chrStoreUnion :: (Ord (TTKey c)) => CHRStore c g -> CHRStore c g -> CHRStore c g chrStoreUnion cs1 cs2 = mkCHRStore $ chrTrieUnionWith cmbStoredCHRs (chrstoreTrie cs1) (chrstoreTrie cs2) {-# INLINE chrStoreUnion #-} -chrStoreUnions :: (Ord (TTKey c)) => [CHRStore c g p] -> CHRStore c g p+chrStoreUnions :: (Ord (TTKey c)) => [CHRStore c g] -> CHRStore c g chrStoreUnions []  = emptyCHRStore chrStoreUnions [s] = s chrStoreUnions ss  = foldr1 chrStoreUnion ss {-# INLINE chrStoreUnions #-} -chrStoreToList :: (Ord (TTKey c)) => CHRStore c g p -> [(CHRKey c,[Rule c g p])]+chrStoreToList :: (Ord (TTKey c)) => CHRStore c g -> [(CHRKey c,[Rule c g () ()])] chrStoreToList cs   = [ (k,chrs)     | (k,e) <- chrTrieToListByKey $ chrstoreTrie cs@@ -165,35 +161,35 @@     , not $ Prelude.null chrs     ] -chrStoreElems :: (Ord (TTKey c)) => CHRStore c g p -> [Rule c g p]+chrStoreElems :: (Ord (TTKey c)) => CHRStore c g -> [Rule c g () ()] chrStoreElems = concatMap snd . chrStoreToList -ppCHRStore :: (PP c, PP g, PP p, Ord (TTKey c), PP (TTKey c)) => CHRStore c g p -> PP_Doc+ppCHRStore :: (PP c, PP g, Ord (TTKey c), PP (TTKey c)) => CHRStore c g -> 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 p -> PP_Doc+ppCHRStore' :: (PP c, PP g, Ord (TTKey c), PP (TTKey c)) => CHRStore c g -> PP_Doc ppCHRStore' = ppCurlysCommasBlock . map (\(k,v) -> ppTreeTrieKey k >-< indent 2 (":" >#< ppBracketsCommasBlock v)) . chrTrieToListByKey . chrstoreTrie  ------------------------------------------------------------------------------------------- --- Solver trace ------------------------------------------------------------------------------------------- -type SolveStep  c g p s = SolveStep'  c (Rule c g p) s-type SolveTrace c g p s = SolveTrace' c (Rule c g p) s+type SolveStep  c g s = SolveStep'  c (Rule c g () ()) s+type SolveTrace c g s = SolveTrace' c (Rule c g () ()) s  ------------------------------------------------------------------------------------------- --- Cache for maintaining which WorkKey has already had a match ------------------------------------------------------------------------------------------- --- type SolveMatchCache c g p s = Map.Map (CHRKey c) [((StoredCHR c g p,([WorkKey c],[Work c])),s)]--- type SolveMatchCache c g p s = Map.Map (WorkKey c) [((StoredCHR c g p,([WorkKey c],[Work c])),s)]-type SolveMatchCache c g p s = SolveMatchCache' c (StoredCHR c g p) s+-- type SolveMatchCache c g b p s = Map.Map (CHRKey c) [((StoredCHR c g,([WorkKey c],[Work c])),s)]+-- type SolveMatchCache c g b p s = Map.Map (WorkKey c) [((StoredCHR c g,([WorkKey c],[Work c])),s)]+type SolveMatchCache c g b p s = SolveMatchCache' c (StoredCHR c g) s  ------------------------------------------------------------------------------------------- --- Solve state ------------------------------------------------------------------------------------------- -type SolveState c g p s = SolveState' c (Rule c g p) (StoredCHR c g p) s+type SolveState c g s = SolveState' c (Rule c g () ()) (StoredCHR c g) s  ------------------------------------------------------------------------------------------- --- Solver@@ -202,63 +198,66 @@ -- | (Class alias) API for solving requirements class ( IsCHRConstraint env c s       , IsCHRGuard env g s-      , IsCHRPrio env p s       , VarLookupCmb s s       , VarUpdatable s s       , CHREmptySubstitution s       , TrTrKey c ~ TTKey c-      ) => IsCHRSolvable env c g p s+      ) => IsCHRSolvable env c g s+        |  c g -> s  {- chrSolve-  :: forall env c g p s .-     ( IsCHRSolvable env c g p s+  :: forall env c g s .+     ( IsCHRSolvable env c g s      )      => env-     -> CHRStore c g p+     -> CHRStore c g      -> [c]      -> [c] chrSolve env chrStore cnstrs   = work ++ done-  where (work, done, _ :: SolveTrace c g p s) = chrSolve' env chrStore cnstrs+  where (work, done, _ :: SolveTrace c g s) = chrSolve' env chrStore cnstrs -}  -- | Solve chrSolve'-  :: forall env c g p s .-     ( IsCHRSolvable env c g p s+  :: forall env c g s .+     ( IsCHRSolvable env c g s      )-     => env-     -> CHRStore c g p+     => [CHRTrOpt]+     -> env+     -> CHRStore c g      -> [c]-     -> ([c],[c],SolveTrace c g p s)-chrSolve' env chrStore cnstrs+     -> ([c],[c],SolveTrace c g s)+chrSolve' tropts env chrStore cnstrs   = (wlToList (stWorkList finalState), stDoneCnstrs finalState, stTrace finalState)-  where finalState = chrSolve'' env chrStore cnstrs emptySolveState+  where finalState = chrSolve'' tropts env chrStore cnstrs emptySolveState  -- | Solve chrSolve''-  :: forall env c g p s .-     ( IsCHRSolvable env c g p s+  :: forall env c g s .+     ( IsCHRSolvable env c g s      )-     => env-     -> CHRStore c g p+     => [CHRTrOpt]+     -> env+     -> CHRStore c g      -> [c]-     -> SolveState c g p s-     -> SolveState c g p s-chrSolve'' env chrStore cnstrs prevState-  = flip execState prevState $ chrSolveM env chrStore cnstrs+     -> SolveState c g s+     -> SolveState c g s+chrSolve'' tropts env chrStore cnstrs prevState+  = flip execState prevState $ chrSolveM tropts env chrStore cnstrs  -- | Solve chrSolveM-  :: forall env c g p s .-     ( IsCHRSolvable env c g p s+  :: forall env c g s .+     ( IsCHRSolvable env c g s      )-     => env-     -> CHRStore c g p+     => [CHRTrOpt]+     -> env+     -> CHRStore c g      -> [c]-     -> State (SolveState c g p s) ()-chrSolveM env chrStore cnstrs = do+     -> State (SolveState c g s) ()+chrSolveM tropts env chrStore cnstrs = do     modify initState     iter {-@@ -284,13 +283,14 @@ -}                               stmatch                       expandMatch matches-                    where -- expandMatch :: SolveState c g p s -> [((StoredCHR c g p, ([WorkKey c], [Work c])), s)] -> SolveState c g p s-                          expandMatch ( ( ( schr@(StoredCHR {storedIdent = chrId, storedChr = chr@(Rule {ruleBody = b, ruleSimpSz = simpSz})})+                    where -- expandMatch :: SolveState c g s -> [((StoredCHR c g, ([WorkKey c], [Work c])), s)] -> SolveState c g s+                          expandMatch ( ( ( schr@(StoredCHR {storedIdent = chrId, storedChr = chr@(Rule {ruleSimpSz = simpSz})})                                           , (keys,works)                                           )                                         , subst                                         ) : tlMatch                                       ) = do+                              let b = ruleBody chr                               st@(SolveState {stWorkList = wl, stHistoryCount = histCount}) <- get                               let (tlMatchY,tlMatchN) = partition (\(r@(_,(ks,_)),_) -> not (any (`elem` keysSimp) ks || slvIsUsedByPropPart (wlUsedIn wl') r)) tlMatch                                   (keysSimp,keysProp) = splitAt simpSz keys@@ -353,8 +353,8 @@                           st'                       iter                     where wl' = wl { wlScanned = workHd : wlScanned wl, wlQueue = workTl }-                          st' = stmatch { stWorkList = wl', stTrace = SolveDbg (ppdbg) : {- -} stTrace stmatch }-              where (matches,lastQuery,ppdbg,stats) = workMatches st+                          st' = stmatch { stWorkList = wl' {- , stTrace = SolveDbg (ppdbg) : stTrace stmatch -} }+              where (matches,lastQuery {- ,ppdbg,stats -}) = workMatches st {-                       stmatch = addStats stats [("(a) workHd", ppTreeTrieKey workHdKey), ("(b) matches", ppBracketsCommasBlock [ s `varUpd` storedChr schr | ((schr,_),s) <- matches ])] -}@@ -372,34 +372,42 @@ -}         addStats _     _   st = st +        mkDbgPP o | o `elem` tropts = id+                  | otherwise       = const Pretty.empty+         workMatches st@(SolveState {stWorkList = WorkList {wlQueue = (workHd@(workHdKey,Work {workTime = workHdTm}) : _), wlTrie = wlTrie, wlUsedIn = wlUsedIn}, stHistoryCount = histCount, stLastQuery = lastQuery})           | isJust mbInCache  = ( fromJust mbInCache                                 , lastQuery-                                , Pretty.empty, mkStats Map.empty [("cache sz",pp (Map.size (stMatchCache st)))]+                                {-+                                , Pretty.empty+                                , mkStats Map.empty [("cache sz",pp (Map.size (stMatchCache st)))]+                                -}                                 )           | otherwise         = ( r5                                 , foldr lqUnion lastQuery [ lqSingleton ck wks histCount | (_,(_,(ck,wks))) <- r23 ]-{-                                 -- , Pretty.empty-                                , pp2 >-< {- pp2b >-< pp2c >-< -} pp3+                                -- , mkDbgPP CHRTrOpt_Lookup $ pp2 >-< pp2b >-< {- pp2c >-< -} pp3+{-                                 , mkStats Map.empty [("(1) lookup sz",pp (length r2)), ("(2) cand sz",pp (length r3)), ("(3) unused cand sz",pp (length r4)), ("(4) final cand sz",pp (length r5))] -}+{-                                 , Pretty.empty-                                , Map.empty+-}+                                -- , Map.empty                                 )           where -- cache result, if present use that, otherwise the below computation                 mbInCache = Map.lookup workHdKey (stMatchCache st)                                  -- results, stepwise computed for later reference in debugging output                 -- basic search result-                r2 :: [StoredCHR c g p]                                       -- CHRs matching workHdKey+                r2 :: [StoredCHR c g]                                       -- CHRs matching workHdKey                 r2  = concat                                                    -- flatten                         $ TreeTrie.lookupResultToList                                   -- convert to list                         $ chrTrieLookup chrLookupHowWildAtTrie workHdKey        -- lookup the store, allowing too many results                         $ chrstoreTrie chrStore                                  -- lookup further info in wlTrie, in particular to find out what has been done already-                r23 :: [( StoredCHR c g p                                     -- the CHR+                r23 :: [( StoredCHR c g                                     -- the CHR                         , ( [( [(CHRKey c, Work c)]                             -- for each CHR the list of constraints, all possible work matches                              , [(CHRKey c, Work c)]                              )]@@ -409,7 +417,7 @@                                  -- possible matches                 r3, r4-                    :: [( StoredCHR c g p                                     -- the matched CHR+                    :: [( StoredCHR c g                                     -- the matched CHR                         , ( [CHRKey c]                                            -- possible matching constraints (matching with the CHR constraints), as Keys, as Works                           , [Work c]                         ) )]@@ -419,19 +427,21 @@                 r4  = filter (not . slvIsUsedByPropPart wlUsedIn) r3                                  -- finally, the 'real' match of the 'real' constraint, yielding (by tupling) substitutions instantiating the found trie matches-                r5  :: [( ( StoredCHR c g p+                r5  :: [( ( StoredCHR c g                           , ( [CHRKey c]                                       , [Work c]                           ) )                         , s                         )]                 r5  = mapMaybe (\r@(chr,kw@(_,works)) -> fmap (\s -> (r,s)) $ slvMatch env chr (map workCnstr works)) r4-{-+                 -- debug info                 pp2  = "lookups"    >#< ("for" >#< ppTreeTrieKey workHdKey >-< ppBracketsCommasBlock r2)+                pp2b = "cand1"      >#< ("lastQ" >#< ppLastQuery lastQuery >-< vlist [ pp (storedKeyedInx chr) | (chr,mtch) <- r23 ])                 -- pp2b = "cand1"      >#< (ppBracketsCommasBlock $ map (ppBracketsCommasBlock . map (ppBracketsCommasBlock . map (\(k,w) -> ppTreeTrieKey k >#< w)) . fst . candidate) r2)                 -- pp2c = "cand2"      >#< (ppBracketsCommasBlock $ map (ppBracketsCommasBlock . map (ppBracketsCommasBlock) . combineToDistinguishedElts . fst . candidate) r2)                 pp3  = "candidates" >#< (ppBracketsCommasBlock $ map (\(chr,(ks,ws)) -> "chr" >#< chr >-< "keys" >#< ppBracketsCommas (map ppTreeTrieKey ks) >-< "works" >#< ppBracketsCommasBlock ws) $ r3)+{- -}         initState st = st { stWorkList = wlInsert (stHistoryCount st) wlnew $ stWorkList st, stDoneCnstrSet = Set.unions [Set.fromList done, stDoneCnstrSet st] }                      where (wlnew,done) = splitDone cnstrs@@ -446,7 +456,7 @@      => CHRKey c      -> LastQuery c      -> WorkTrie c-     -> StoredCHR c g p+     -> StoredCHR c g      -> ( [( [(CHRKey c, Work c)]            , [(CHRKey c, Work c)]            )]@@ -457,7 +467,10 @@     , ( ck       , Set.fromList $ map (maybe workHdKey id) ks     ) )-  where lkup how k = partition (\(_,w) -> workTime w < lastQueryTm) $ map (\w -> (workKey w,w)) $ TreeTrie.lookupResultToList $ chrTrieLookup how k wlTrie+  where lkup how k = partition (\(_,w) -> workTime w < lastQueryTm)+                       $ map (\w -> (workKey w,w))+                       $ TreeTrie.lookupResultToList+                       $ chrTrieLookup how k wlTrie                    where lastQueryTm = lqLookupW k $ lqLookupC ck lastQuery {-# INLINE slvCandidate #-} @@ -466,7 +479,7 @@ slvIsUsedByPropPart   :: (Ord k, Ord (TTKey c))      => Map.Map (Set.Set k) (Set.Set (UsedByKey c))-     -> (StoredCHR c g p, ([k], t))+     -> (StoredCHR c g, ([k], t))      -> Bool slvIsUsedByPropPart wlUsedIn (chr,(keys,_))   = fnd $ drop (storedSimpSz chr) keys@@ -480,7 +493,7 @@      , CHRCheckable env g s      , VarLookupCmb s s      )-     => env -> StoredCHR c g p -> [c] -> Maybe s+     => env -> StoredCHR c g -> [c] -> Maybe s slvMatch env chr cnstrs   = foldl cmb (Just chrEmptySubst) $ matches chr cnstrs ++ checks chr   where matches (StoredCHR {storedChr = Rule {ruleHead = hc}}) cnstrs@@ -497,11 +510,11 @@ --- Instances: Serialize ------------------------------------------------------------------------------------------- -instance (Ord (TTKey c), Serialize (TTKey c), Serialize c, Serialize g, Serialize p) => Serialize (CHRStore c g p) where+instance (Ord (TTKey c), Serialize (TTKey c), Serialize c, Serialize g) => Serialize (CHRStore c g) where   sput (CHRStore a) = sput a   sget = liftM CHRStore sget   -instance (Serialize c, Serialize g, Serialize p, Serialize (TTKey c)) => Serialize (StoredCHR c g p) where+instance (Serialize c, Serialize g, Serialize (TTKey c)) => Serialize (StoredCHR c g) where   sput (StoredCHR a b c d) = sput a >> sput b >> sput c >> sput d   sget = liftM4 StoredCHR sget sget sget sget 

@@ -1,540 +1,1146 @@-{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, UndecidableInstances, NoMonomorphismRestriction, MultiParamTypeClasses #-}------------------------------------------------------------------------------------------------- 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.--}--module UHC.Util.CHR.Solve.TreeTrie.MonoBacktrackPrio-  (-  )-{--  ( 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.Solve.TreeTrie.Internal-import           UHC.Util.Substitutable-import           UHC.Util.VarLookup-import           UHC.Util.VarMp-import           UHC.Util.AssocL-import           UHC.Util.TreeTrie as TreeTrie-import qualified Data.Set as Set-import qualified Data.Map as Map-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.State.Strict-import           UHC.Util.Utils------------------------------------------------------------------------------------------------- The CHR monad, state, etc------------------------------------------------------------------------------------------------ | Global state-data CHRGlobState cnstr guard prio-  = CHRGlobState-      { chrgstStore                 :: !(CHRStore cnstr guard prio)      -- ^ Actual database of rules, to be searched-      , chrgstNextFreeRuleInx       :: !Int                         -- ^ 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.-      }-  deriving (Typeable)------------------------------------------------------------------------------------------------- CHR store, with fast search------------------------------------------------------------------------------------------------ | A CHR as stored in a CHRStore, requiring additional info for efficiency-data StoredCHR c g p-  = StoredCHR-      { storedChr       :: !(Rule c g p)      -- the Rule-      , storedKeyedInx  :: !Int                             -- index of constraint for which is keyed into store-      , storedKeys      :: ![Maybe (CHRKey c)]                  -- keys of all constraints; at storedKeyedInx: Nothing-      , storedIdent     :: !(UsedByKey c)                       -- the identification of a CHR, used for propagation rules (see remark at begin)-      }-  deriving (Typeable)--{--deriving instance (Data (TTKey c), Data c, Data g) => Data (StoredCHR c g p)--type instance TTKey (StoredCHR c g p) = TTKey c--instance (TTKeyable (Rule c g p)) => TTKeyable (StoredCHR c g p) where-  toTTKey' o schr = toTTKey' o $ storedChr schr---- | The size of the simplification part of a CHR-storedSimpSz :: StoredCHR c g p -> Int-storedSimpSz = ruleSimpSz . storedChr-{-# INLINE storedSimpSz #-}--}---- | A CHR store is a trie structure-newtype CHRStore cnstr guard prio-  = CHRStore-      { chrstoreTrie    :: CHRTrie [StoredCHR cnstr guard prio]-      }-  deriving (Typeable)--{---- deriving instance (Data (TTKey cnstr), Ord (TTKey cnstr), Data cnstr, Data guard) => Data (CHRStore cnstr guard prio)--mkCHRStore trie = CHRStore trie--emptyCHRStore :: CHRStore cnstr guard prio-emptyCHRStore = mkCHRStore emptyCHRTrie---- | Combine lists of stored CHRs by concat, adapting their identification nr to be unique-cmbStoredCHRs :: [StoredCHR c g p] -> [StoredCHR c g p] -> [StoredCHR c g 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 p) where-  show _ = "StoredCHR"--ppStoredCHR :: (PP (TTKey c), PP c, PP g, PP p) => StoredCHR c g p -> PP_Doc-ppStoredCHR c@(StoredCHR {storedIdent=(idKey,idSeqNr)})-  = storedChr c-    >-< indent 2-          (ppParensCommas-            [ pp $ storedKeyedInx 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 p) => PP (StoredCHR c g p) where-  pp = ppStoredCHR---- | Convert from list to store-chrStoreFromElems :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => [Rule c g p] -> CHRStore c g 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-        ]--chrStoreSingletonElem :: (TTKeyable c, Ord (TTKey c), TTKey c ~ TrTrKey c) => Rule c g p -> CHRStore c g p-chrStoreSingletonElem x = chrStoreFromElems [x]--chrStoreUnion :: (Ord (TTKey c)) => CHRStore c g p -> CHRStore c g p -> CHRStore c g p-chrStoreUnion cs1 cs2 = mkCHRStore $ chrTrieUnionWith cmbStoredCHRs (chrstoreTrie cs1) (chrstoreTrie cs2)-{-# INLINE chrStoreUnion #-}--chrStoreUnions :: (Ord (TTKey c)) => [CHRStore c g p] -> CHRStore c g p-chrStoreUnions []  = emptyCHRStore-chrStoreUnions [s] = s-chrStoreUnions ss  = foldr1 chrStoreUnion ss-{-# INLINE chrStoreUnions #-}--chrStoreToList :: (Ord (TTKey c)) => CHRStore c g p -> [(CHRKey c,[Rule c g p])]-chrStoreToList cs-  = [ (k,chrs)-    | (k,e) <- chrTrieToListByKey $ chrstoreTrie cs-    , let chrs = [chr | (StoredCHR {storedChr = chr, storedKeyedInx = 0}) <- e]-    , not $ Prelude.null chrs-    ]--chrStoreElems :: (Ord (TTKey c)) => CHRStore c g p -> [Rule c g p]-chrStoreElems = concatMap snd . chrStoreToList--ppCHRStore :: (PP c, PP g, PP p, Ord (TTKey c), PP (TTKey c)) => CHRStore c g 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 p -> PP_Doc-ppCHRStore' = ppCurlysCommasBlock . map (\(k,v) -> ppTreeTrieKey k >-< indent 2 (":" >#< ppBracketsCommasBlock v)) . chrTrieToListByKey . chrstoreTrie---}------------------------------------------------------------------------------------------------- Solver trace----------------------------------------------------------------------------------------------{--type SolveStep  c g p s = SolveStep'  c (Rule c g p) s-type SolveTrace c g p s = SolveTrace' c (Rule c g p) s--}------------------------------------------------------------------------------------------------- Cache for maintaining which WorkKey has already had a match----------------------------------------------------------------------------------------------{---- type SolveMatchCache c g p s = Map.Map (CHRKey c) [((StoredCHR c g p,([WorkKey c],[Work c])),s)]--- type SolveMatchCache c g p s = Map.Map (WorkKey c) [((StoredCHR c g p,([WorkKey c],[Work c])),s)]-type SolveMatchCache c g p s = SolveMatchCache' c (StoredCHR c g p) s--}------------------------------------------------------------------------------------------------- Solve state----------------------------------------------------------------------------------------------{--type SolveState c g p s = SolveState' c (Rule c g p) (StoredCHR c g p) s--}------------------------------------------------------------------------------------------------- Solver----------------------------------------------------------------------------------------------{---- | (Class alias) API for solving requirements-class ( IsCHRConstraint env c s-      , IsCHRGuard env g s-      , VarLookupCmb s s-      , VarUpdatable s s-      , CHREmptySubstitution s-      , TrTrKey c ~ TTKey c-      ) => IsCHRSolvable env c g p s--}--{--chrSolve-  :: forall env c g p s .-     ( IsCHRSolvable env c g p s-     )-     => env-     -> CHRStore c g p-     -> [c]-     -> [c]-chrSolve env chrStore cnstrs-  = work ++ done-  where (work, done, _ :: SolveTrace c g p s) = chrSolve' env chrStore cnstrs--}--{---- | Solve-chrSolve'-  :: forall env c g p s .-     ( IsCHRSolvable env c g p s-     )-     => env-     -> CHRStore c g p-     -> [c]-     -> ([c],[c],SolveTrace c g p s)-chrSolve' env chrStore cnstrs-  = (wlToList (stWorkList finalState), stDoneCnstrs finalState, stTrace finalState)-  where finalState = chrSolve'' env chrStore cnstrs emptySolveState---- | Solve-chrSolve''-  :: forall env c g p s .-     ( IsCHRSolvable env c g p s-     )-     => env-     -> CHRStore c g p-     -> [c]-     -> SolveState c g p s-     -> SolveState c g p s-chrSolve'' env chrStore cnstrs prevState-  = flip execState prevState $ chrSolveM env chrStore cnstrs---- | Solve-chrSolveM-  :: forall env c g p s .-     ( IsCHRSolvable env c g p s-     )-     => env-     -> CHRStore c g p-     -> [c]-     -> State (SolveState c g p s) ()-chrSolveM env chrStore cnstrs = do-    modify initState-    iter-{--    modify $-            addStats Map.empty-                [ ("workMatches",ppAssocLV [(ppTreeTrieKey k,pp (fromJust l))-                | (k,c) <- Map.toList $ stCountCnstr st, let l = Map.lookup "workMatched" c, isJust l])-                ]--}-    modify $ \st -> st {stMatchCache = Map.empty}-  where iter = do-          st <- get-          case st of-            (SolveState {stWorkList = wl@(WorkList {wlQueue = (workHd@(workHdKey,_) : workTl)})}) ->-                case matches of-                  (_:_) -> do-                      put -{-   -                          $ addStats Map.empty-                                [ ("(0) yes work", ppTreeTrieKey workHdKey)-                                ]-                          $--}    -                          stmatch-                      expandMatch matches-                    where -- expandMatch :: SolveState c g p s -> [((StoredCHR c g p, ([WorkKey c], [Work c])), s)] -> SolveState c g p s-                          expandMatch ( ( ( schr@(StoredCHR {storedIdent = chrId, storedChr = chr@(Rule {ruleBody = b, ruleSimpSz = simpSz})})-                                          , (keys,works)-                                          )-                                        , subst-                                        ) : tlMatch-                                      ) = do-                              st@(SolveState {stWorkList = wl, stHistoryCount = histCount}) <- get-                              let (tlMatchY,tlMatchN) = partition (\(r@(_,(ks,_)),_) -> not (any (`elem` keysSimp) ks || slvIsUsedByPropPart (wlUsedIn wl') r)) tlMatch-                                  (keysSimp,keysProp) = splitAt simpSz keys-                                  usedIn              = Map.singleton (Set.fromList keysProp) (Set.singleton chrId)-                                  (bTodo,bDone)       = splitDone $ map (varUpd subst) b-                                  bTodo'              = wlCnstrToIns wl bTodo-                                  wl' = wlDeleteByKeyAndInsert' histCount keysSimp bTodo'-                                        $ wl { wlUsedIn  = usedIn `wlUsedInUnion` wlUsedIn wl-                                             , wlScanned = []-                                             , wlQueue   = wlQueue wl ++ wlScanned wl-                                             }-                                  st' = st { stWorkList       = wl'-{-  -                                           , stTrace          = SolveStep chr' subst (assocLElts bTodo') bDone : {- SolveDbg (ppwork >-< ppdbg) : -} stTrace st--}    -                                           , stDoneCnstrSet   = Set.unions [Set.fromList bDone, Set.fromList $ map workCnstr $ take simpSz works, stDoneCnstrSet st]-                                           , stMatchCache     = if List.null bTodo' then stMatchCache st else Map.empty-                                           , stHistoryCount   = histCount + 1-                                           }-{-   -                                  chr'= subst `varUpd` chr-                                  ppwork = "workkey" >#< ppTreeTrieKey workHdKey >#< ":" >#< (ppBracketsCommas (map (ppTreeTrieKey . fst) workTl) >-< ppBracketsCommas (map (ppTreeTrieKey . fst) $ wlScanned wl))-                                             >-< "workkeys" >#< ppBracketsCommas (map ppTreeTrieKey keys)-                                             >-< "worktrie" >#< wlTrie wl-                                             >-< "schr" >#< schr-                                             >-< "usedin" >#< (ppBracketsCommasBlock $ map (\(k,s) -> ppKs k >#< ppBracketsCommas (map ppUsedByKey $ Set.toList s)) $ Map.toList $ wlUsedIn wl)-                                             >-< "usedin'" >#< (ppBracketsCommasBlock $ map (\(k,s) -> ppKs k >#< ppBracketsCommas (map ppUsedByKey $ Set.toList s)) $ Map.toList $ wlUsedIn wl')-                                         where ppKs ks = ppBracketsCommas $ map ppTreeTrieKey $ Set.toList ks--}   -                              put-{-   -                                  $ addStats Map.empty-                                        [ ("chr",pp chr')-                                        , ("leftover sz", pp (length tlMatchY))-                                        , ("filtered out sz", pp (length tlMatchN))-                                        , ("new done sz", pp (length bDone))-                                        , ("new todo sz", pp (length bTodo))-                                        , ("wl queue sz", pp (length (wlQueue wl')))-                                        , ("wl usedin sz", pp (Map.size (wlUsedIn wl')))-                                        , ("done sz", pp (Set.size (stDoneCnstrSet st')))-                                        , ("hist cnt", pp histCount)-                                        ]-                                  $--}   -                                  st'-                              expandMatch tlMatchY--                          expandMatch _ -                            = iter-                          -                  _ -> do-                      put-{-   -                          $ addStats Map.empty-                                [ ("no match work", ppTreeTrieKey workHdKey)-                                , ("wl queue sz", pp (length (wlQueue wl')))-                                ]-                          $--}    -                          st'-                      iter-                    where wl' = wl { wlScanned = workHd : wlScanned wl, wlQueue = workTl }-                          st' = stmatch { stWorkList = wl', stTrace = SolveDbg (ppdbg) : {- -} stTrace stmatch }-              where (matches,lastQuery,ppdbg,stats) = workMatches st-{-  -                    stmatch = addStats stats [("(a) workHd", ppTreeTrieKey workHdKey), ("(b) matches", ppBracketsCommasBlock [ s `varUpd` storedChr schr | ((schr,_),s) <- matches ])]--}-                    stmatch =  -                                (st { stCountCnstr = scntInc workHdKey "workMatched" $ stCountCnstr st-                                    , stMatchCache = Map.insert workHdKey [] (stMatchCache st)-                                    , stLastQuery  = lastQuery-                                    })-            _ -> do-                return ()--        mkStats  stats new    = stats `Map.union` Map.fromList (assocLMapKey showPP new)-{--        addStats stats new st = st { stTrace = SolveStats (mkStats stats new) : stTrace st }--}-        addStats _     _   st = st--        workMatches st@(SolveState {stWorkList = WorkList {wlQueue = (workHd@(workHdKey,Work {workTime = workHdTm}) : _), wlTrie = wlTrie, wlUsedIn = wlUsedIn}, stHistoryCount = histCount, stLastQuery = lastQuery})-          | isJust mbInCache  = ( fromJust mbInCache-                                , lastQuery-                                , Pretty.empty, mkStats Map.empty [("cache sz",pp (Map.size (stMatchCache st)))]-                                )-          | otherwise         = ( r5-                                , foldr lqUnion lastQuery [ lqSingleton ck wks histCount | (_,(_,(ck,wks))) <- r23 ]-{--                                -- , Pretty.empty-                                , pp2 >-< {- pp2b >-< pp2c >-< -} pp3-                                , mkStats Map.empty [("(1) lookup sz",pp (length r2)), ("(2) cand sz",pp (length r3)), ("(3) unused cand sz",pp (length r4)), ("(4) final cand sz",pp (length r5))]--}-                                , Pretty.empty-                                , Map.empty-                                )-          where -- cache result, if present use that, otherwise the below computation-                mbInCache = Map.lookup workHdKey (stMatchCache st)-                -                -- results, stepwise computed for later reference in debugging output-                -- basic search result-                r2 :: [StoredCHR c g p]                                       -- CHRs matching workHdKey-                r2  = concat                                                    -- flatten-                        $ TreeTrie.lookupResultToList                                   -- convert to list-                        $ chrTrieLookup chrLookupHowWildAtTrie workHdKey        -- lookup the store, allowing too many results-                        $ chrstoreTrie chrStore-                -                -- lookup further info in wlTrie, in particular to find out what has been done already-                r23 :: [( StoredCHR c g p                                     -- the CHR-                        , ( [( [(CHRKey c, Work c)]                             -- for each CHR the list of constraints, all possible work matches-                             , [(CHRKey c, Work c)]-                             )]-                          , (CHRKey c, Set.Set (CHRKey c))-                        ) )]-                r23 = map (\c -> (c, slvCandidate workHdKey lastQuery wlTrie c)) r2-                -                -- possible matches-                r3, r4-                    :: [( StoredCHR c g p                                     -- the matched CHR-                        , ( [CHRKey c]                                            -- possible matching constraints (matching with the CHR constraints), as Keys, as Works-                          , [Work c]-                        ) )]-                r3  = concatMap (\(c,cands) -> zip (repeat c) (map unzip $ slvCombine cands)) $ r23-                -                -- same, but now restricted to not used earlier as indicated by the worklist-                r4  = filter (not . slvIsUsedByPropPart wlUsedIn) r3-                -                -- finally, the 'real' match of the 'real' constraint, yielding (by tupling) substitutions instantiating the found trie matches-                r5  :: [( ( StoredCHR c g p-                          , ( [CHRKey c]          -                            , [Work c]-                          ) )-                        , s-                        )]-                r5  = mapMaybe (\r@(chr,kw@(_,works)) -> fmap (\s -> (r,s)) $ slvMatch env chr (map workCnstr works)) r4-{--                -- debug info-                pp2  = "lookups"    >#< ("for" >#< ppTreeTrieKey workHdKey >-< ppBracketsCommasBlock r2)-                -- pp2b = "cand1"      >#< (ppBracketsCommasBlock $ map (ppBracketsCommasBlock . map (ppBracketsCommasBlock . map (\(k,w) -> ppTreeTrieKey k >#< w)) . fst . candidate) r2)-                -- pp2c = "cand2"      >#< (ppBracketsCommasBlock $ map (ppBracketsCommasBlock . map (ppBracketsCommasBlock) . combineToDistinguishedElts . fst . candidate) r2)-                pp3  = "candidates" >#< (ppBracketsCommasBlock $ map (\(chr,(ks,ws)) -> "chr" >#< chr >-< "keys" >#< ppBracketsCommas (map ppTreeTrieKey ks) >-< "works" >#< ppBracketsCommasBlock ws) $ r3)--}-        initState st = st { stWorkList = wlInsert (stHistoryCount st) wlnew $ stWorkList st, stDoneCnstrSet = Set.unions [Set.fromList done, stDoneCnstrSet st] }-                     where (wlnew,done) = splitDone cnstrs-        splitDone  = partition cnstrRequiresSolve---- | 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-  :: (Ord (TTKey c), PP (TTKey c))-     => CHRKey c-     -> LastQuery c-     -> WorkTrie c-     -> StoredCHR c g p-     -> ( [( [(CHRKey c, Work c)]-           , [(CHRKey c, Work c)]-           )]-        , (CHRKey c, Set.Set (CHRKey c))-        )-slvCandidate workHdKey lastQuery wlTrie (StoredCHR {storedIdent = (ck,_), storedKeys = ks, storedChr = chr})-  = ( map (maybe (lkup chrLookupHowExact workHdKey) (lkup chrLookupHowWildAtKey)) ks-    , ( ck-      , Set.fromList $ map (maybe workHdKey id) ks-    ) )-  where lkup how k = partition (\(_,w) -> workTime w < lastQueryTm) $ map (\w -> (workKey w,w)) $ TreeTrie.lookupResultToList $ chrTrieLookup how k wlTrie-                   where lastQueryTm = lqLookupW k $ lqLookupC ck lastQuery-{-# INLINE slvCandidate #-}---- | Check whether the CHR propagation part of a match already has been used (i.e. propagated) earlier,---   this to avoid duplicate propagation.-slvIsUsedByPropPart-  :: (Ord k, Ord (TTKey c))-     => Map.Map (Set.Set k) (Set.Set (UsedByKey c))-     -> (StoredCHR c g p, ([k], t))-     -> Bool-slvIsUsedByPropPart wlUsedIn (chr,(keys,_))-  = fnd $ drop (storedSimpSz chr) keys-  where fnd k = maybe False (storedIdent chr `Set.member`) $ Map.lookup (Set.fromList k) wlUsedIn-{-# INLINE slvIsUsedByPropPart #-}---- | Match the stored CHR with a set of possible constraints, giving a substitution on success-slvMatch-  :: ( CHREmptySubstitution s-     , CHRMatchable env c s-     , CHRCheckable env g s-     , VarLookupCmb s s-     )-     => env -> StoredCHR c g p -> [c] -> Maybe s-slvMatch env chr cnstrs-  = foldl cmb (Just chrEmptySubst) $ matches chr cnstrs ++ checks chr-  where matches (StoredCHR {storedChr = Rule {ruleHead = hc}}) cnstrs-          = zipWith mt hc cnstrs-          where mt cFr cTo subst = chrMatchTo env subst cFr cTo-        checks (StoredCHR {storedChr = Rule {ruleGuard = gd}})-          = map chk gd-          where chk g subst = chrCheck env subst g-        cmb (Just s) next = fmap (|+> s) $ next s-        cmb _        _    = Nothing-{-# INLINE slvMatch #-}---}------------------------------------------------------------------------------------------------- Instances: Serialize----------------------------------------------------------------------------------------------{--instance (Ord (TTKey c), Serialize (TTKey c), Serialize c, Serialize g, Serialize p) => Serialize (CHRStore c g p) where-  sput (CHRStore a) = sput a-  sget = liftM CHRStore sget-  -instance (Serialize c, Serialize g, Serialize p, Serialize (TTKey c)) => Serialize (StoredCHR c g p) where+{-# 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+  +  , 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)++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 = 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 +          [] -> slv+          -- just reschedule+          [alt@(FoundBodyAlt {foundBodyAltBacktrackPrio=bprio})]+            | curbprio == bprio -> nextwork bprio alt+            | otherwise -> do+                slvSchedule bprio $ nextwork bprio alt+                slvScheduleRun+          -- otherwise backtrack and schedule all and then reschedule+          alts -> do+                forM alts $ \alt@(FoundBodyAlt {foundBodyAltBacktrackPrio=bprio}) -> (backtrack $ nextwork bprio alt) >>= slvSchedule bprio+                slvScheduleRun++      where+        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,506 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, UndecidableInstances, NoMonomorphismRestriction, MultiParamTypeClasses #-}------------------------------------------------------------------------------------------------- CHR solver----------------------------------------------------------------------------------------------{-|-Derived from work by Gerrit vd Geest, but greatly adapted to use more efficient searching.--Assumptions (to be documented further)-- The key [Trie.TrieKey Key] used to lookup a constraint in a CHR should be distinguishing enough to be used for the prevention-  of the application of a propagation rule for a 2nd time.--This is a polymorphic Solver, i.e. the solver is unaware of the type of constraints, rules, etc. because of this type hidden existentially.-Tying stuff together is now done by phantom types for environment and substitution, instantiated/relevant only when solving.--}--module UHC.Util.CHR.Solve.TreeTrie.Poly-  ( -    CHRStore-  , emptyCHRStore-  -  , chrStoreFromElems-  , chrStoreSingletonElem-  , chrStoreUnion-  , chrStoreUnions-  , 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.Solve.TreeTrie.Internal-import           UHC.Util.Substitutable-import           UHC.Util.VarLookup-import           UHC.Util.VarMp-import           UHC.Util.AssocL-import           UHC.Util.TreeTrie as TreeTrie-import qualified Data.Set as Set-import qualified Data.Map as Map-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.State.Strict-import           UHC.Util.Utils------------------------------------------------------------------------------------------------- CHR store, with fast search------------------------------------------------------------------------------------------------ | A CHR as stored in a CHRStore, requiring additional info for efficiency-data StoredCHR e s-  = StoredCHR-      { storedChr       :: !(CHRRule e s)      -- the Rule-      , storedKeyedInx  :: !Int                             -- index of constraint for which is keyed into store-      , storedKeys      :: ![Maybe (CHRKey (CHRConstraint e s))]                  -- keys of all constraints; at storedKeyedInx: Nothing-      , storedIdent     :: !(UsedByKey (CHRConstraint e s))                       -- the identification of a CHR, used for propagation rules (see remark at begin)-      }-  deriving (Typeable)--deriving instance (Data (TTKey (CHRConstraint e s)), Data (CHRRule e s), Data e, Data s) => Data (StoredCHR e s)--type instance TTKey (StoredCHR e s) = TTKey (CHRRule e s)--instance (TTKeyable (CHRRule e s)) => TTKeyable (StoredCHR e s) where-  toTTKey' o schr = toTTKey' o $ storedChr schr---- | The size of the simplification part of a CHR-storedSimpSz :: StoredCHR e s -> Int-storedSimpSz = ruleSimpSz . chrRule . storedChr-{-# INLINE storedSimpSz #-}---- | A CHR store is a trie structure-newtype CHRStore e s-  = CHRStore-      { chrstoreTrie    :: CHRTrie [StoredCHR e s]-      }-  deriving (Typeable)---- deriving instance (Ord (TTKey (CHRRule e s)), Data e, Data s, Data (TTKey (CHRRule e s)), Data (TTKey (CHRConstraint e s)), Data (CHRRule e s)) => Data (CHRStore e s)--mkCHRStore trie = CHRStore trie--emptyCHRStore :: CHRStore cnstr guard-emptyCHRStore = mkCHRStore emptyCHRTrie---- | Combine lists of stored CHRs by concat, adapting their identification nr to be unique-cmbStoredCHRs :: [StoredCHR e s] -> [StoredCHR e s] -> [StoredCHR e s]-cmbStoredCHRs s1 s2-  = map (\s@(StoredCHR {storedIdent=(k,nr)}) -> s {storedIdent = (k,nr+l)}) s1 ++ s2-  where l = length s2--instance Show (StoredCHR e s) where-  show _ = "StoredCHR"--ppStoredCHR :: (PP (TTKey (CHRConstraint e s))) => StoredCHR e s -> PP_Doc-ppStoredCHR c@(StoredCHR {storedIdent=(idKey,idSeqNr)})-  = storedChr c-    >-< indent 2-          (ppParensCommas-            [ pp $ storedKeyedInx c-            , pp $ storedSimpSz c-            , "keys" >#< (ppBracketsCommas $ map (maybe (pp "?") ppTreeTrieKey) $ storedKeys c)-            , "ident" >#< ppParensCommas [ppTreeTrieKey idKey,pp idSeqNr]-            ])--instance (PP (TTKey (CHRConstraint e s))) => PP (StoredCHR e s) where-  pp = ppStoredCHR---- | Convert from list to store-chrStoreFromElems-  :: (Ord (TTKey (CHRConstraint e s)), TTKey (CHRConstraint e s) ~ TrTrKey (CHRConstraint e s))-  => [CHRRule e s]-  -> CHRStore e s-chrStoreFromElems cruls-  = mkCHRStore-    $ chrTrieFromListByKeyWith cmbStoredCHRs-        [ (k,[StoredCHR crul i ks' (concat ks,0)])-        | crul@(CHRRule rul) <- cruls-        , let cs = ruleHead rul-              simpSz = ruleSimpSz rul-              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-        ]---chrStoreSingletonElem-  :: (Ord (TTKey (CHRConstraint e s)), TTKey (CHRConstraint e s) ~ TrTrKey (CHRConstraint e s))-  => CHRRule e s-  -> CHRStore e s-chrStoreSingletonElem x = chrStoreFromElems [x]--chrStoreUnion :: (Ord (TTKey (CHRConstraint e s))) => CHRStore e s -> CHRStore e s -> CHRStore e s-chrStoreUnion cs1 cs2 = mkCHRStore $ chrTrieUnionWith cmbStoredCHRs (chrstoreTrie cs1) (chrstoreTrie cs2)-{-# INLINE chrStoreUnion #-}--chrStoreUnions :: (Ord (TTKey (CHRConstraint e s))) => [CHRStore e s] -> CHRStore e s-chrStoreUnions []  = emptyCHRStore-chrStoreUnions [s] = s-chrStoreUnions ss  = foldr1 chrStoreUnion ss-{-# INLINE chrStoreUnions #-}--chrStoreToList :: (Ord (TTKey (CHRConstraint e s))) => CHRStore e s -> [(CHRKey (CHRConstraint e s),[CHRRule e s])]-chrStoreToList cs-  = [ (k,chrs)-    | (k,e) <- chrTrieToListByKey $ chrstoreTrie cs-    , let chrs = [chr | (StoredCHR {storedChr = chr, storedKeyedInx = 0}) <- e]-    , not $ Prelude.null chrs-    ]--chrStoreElems :: (Ord (TTKey (CHRConstraint e s))) => CHRStore e s -> [CHRRule e s]-chrStoreElems = concatMap snd . chrStoreToList--ppCHRStore :: (PP (TTKey (CHRConstraint e s)), Ord (TTKey (CHRConstraint e s))) => {- (PP c, PP g, Ord (TTKey c), PP (TTKey c)) => -} CHRStore e s -> PP_Doc-ppCHRStore = ppCurlysCommasBlock . map (\(k,v) -> ppTreeTrieKey k >-< indent 2 (":" >#< ppBracketsCommasBlock v)) . chrStoreToList--ppCHRStore' :: (PP (TTKey (CHRConstraint e s)), Ord (TTKey (CHRConstraint e s))) => CHRStore e s -> PP_Doc-ppCHRStore' = ppCurlysCommasBlock . map (\(k,v) -> ppTreeTrieKey k >-< indent 2 (":" >#< ppBracketsCommasBlock v)) . chrTrieToListByKey . chrstoreTrie------------------------------------------------------------------------------------------------- Solver trace----------------------------------------------------------------------------------------------type SolveStep  e s = SolveStep'  (CHRConstraint e s) (CHRRule e s) s-type SolveTrace e s = SolveTrace' (CHRConstraint e s) (CHRRule e s) s------------------------------------------------------------------------------------------------- Cache for maintaining which WorkKey has already had a match----------------------------------------------------------------------------------------------type SolveMatchCache e s = SolveMatchCache' (CHRConstraint e s) (StoredCHR e s) s------------------------------------------------------------------------------------------------- Solve state----------------------------------------------------------------------------------------------type SolveState e s = SolveState' (CHRConstraint e s) (CHRRule e s) (StoredCHR e s) s------------------------------------------------------------------------------------------------- Solver------------------------------------------------------------------------------------------------- | (Class alias) API for solving requirements-class ( VarLookupCmb s s-      , VarUpdatable s s-      , CHREmptySubstitution s-      , TrTrKey (CHRConstraint e s) ~ TTKey (CHRConstraint e s)-      , CHRMatchableKey s ~ TrTrKey (CHRConstraint e s)-      , PP (CHRMatchableKey s)-      , Ord (CHRMatchableKey s)-      ) => IsCHRSolvable e s---- | Solve-chrSolve'-  :: forall e c s .-     ( IsCHRSolvable e s-     , c ~ CHRConstraint e s-     )-     => e-     -> CHRStore e s-     -> [c]-     -> ([c],[c],SolveTrace e s)-chrSolve' env chrStore cnstrs-  = (wlToList (stWorkList finalState), stDoneCnstrs finalState, stTrace finalState)-  where finalState = chrSolve'' env chrStore cnstrs emptySolveState---- | Solve-chrSolve''-  :: forall e c s .-     ( IsCHRSolvable e s-     , c ~ CHRConstraint e s-     )-     => e-     -> CHRStore e s-     -> [c]-     -> SolveState e s-     -> SolveState e s-chrSolve'' env chrStore cnstrs prevState-  = flip execState prevState $ chrSolveM env chrStore cnstrs----- | Solve-chrSolveM-  :: forall e c s .-     ( IsCHRSolvable e s-     , c ~ CHRConstraint e s-     )-     => e-     -> CHRStore e s-     -> [c]-     -> State (SolveState e s) ()-chrSolveM env chrStore cnstrs = do-    modify initState-    iter-{--    modify $-            addStats Map.empty-                [ ("workMatches",ppAssocLV [(ppTreeTrieKey k,pp (fromJust l))-                | (k,c) <- Map.toList $ stCountCnstr st, let l = Map.lookup "workMatched" c, isJust l])-                ]--}-    modify $ \st -> st {stMatchCache = Map.empty}-  where iter = do-          st <- get-          case st of-            (SolveState {stWorkList = wl@(WorkList {wlQueue = (workHd@(workHdKey,_) : workTl)})}) ->-                case matches of-                  (_:_) -> do-                      put -{-   -                          $ addStats Map.empty-                                [ ("(0) yes work", ppTreeTrieKey workHdKey)-                                ]-                          $--}    -                          stmatch-                      expandMatch matches-                    where -- expandMatch :: SolveState e s -> [((StoredCHR e s, ([WorkKey c], [Work c])), s)] -> SolveState e s-                          expandMatch ( ( ( schr@(StoredCHR {storedIdent = chrId, storedChr = chr@(CHRRule {chrRule = Rule {ruleBody = b, ruleSimpSz = simpSz}})})-                                          , (keys,works)-                                          )-                                        , subst-                                        ) : tlMatch-                                      ) = do-                              st@(SolveState {stWorkList = wl, stHistoryCount = histCount}) <- get-                              let (tlMatchY,tlMatchN) = partition (\(r@(_,(ks,_)),_) -> not (any (`elem` keysSimp) ks || slvIsUsedByPropPart (wlUsedIn wl') r)) tlMatch-                                  (keysSimp,keysProp) = splitAt simpSz keys-                                  usedIn              = Map.singleton (Set.fromList keysProp) (Set.singleton chrId)-                                  (bTodo,bDone)       = splitDone $ map (varUpd subst) b-                                  bTodo'              = wlCnstrToIns wl bTodo-                                  wl' = wlDeleteByKeyAndInsert' histCount keysSimp bTodo'-                                        $ wl { wlUsedIn  = usedIn `wlUsedInUnion` wlUsedIn wl-                                             , wlScanned = []-                                             , wlQueue   = wlQueue wl ++ wlScanned wl-                                             }-                                  st' = st { stWorkList       = wl'-{-  -                                           , stTrace          = SolveStep chr' subst (assocLElts bTodo') bDone : {- SolveDbg (ppwork >-< ppdbg) : -} stTrace st--}    -                                           , stDoneCnstrSet   = Set.unions [Set.fromList bDone, Set.fromList $ map workCnstr $ take simpSz works, stDoneCnstrSet st]-                                           , stMatchCache     = if List.null bTodo' then stMatchCache st else Map.empty-                                           , stHistoryCount   = histCount + 1-                                           }-{-   -                                  chr'= subst `varUpd` chr-                                  ppwork = "workkey" >#< ppTreeTrieKey workHdKey >#< ":" >#< (ppBracketsCommas (map (ppTreeTrieKey . fst) workTl) >-< ppBracketsCommas (map (ppTreeTrieKey . fst) $ wlScanned wl))-                                             >-< "workkeys" >#< ppBracketsCommas (map ppTreeTrieKey keys)-                                             >-< "worktrie" >#< wlTrie wl-                                             >-< "schr" >#< schr-                                             >-< "usedin" >#< (ppBracketsCommasBlock $ map (\(k,s) -> ppKs k >#< ppBracketsCommas (map ppUsedByKey $ Set.toList s)) $ Map.toList $ wlUsedIn wl)-                                             >-< "usedin'" >#< (ppBracketsCommasBlock $ map (\(k,s) -> ppKs k >#< ppBracketsCommas (map ppUsedByKey $ Set.toList s)) $ Map.toList $ wlUsedIn wl')-                                         where ppKs ks = ppBracketsCommas $ map ppTreeTrieKey $ Set.toList ks--}   -                              put-{-   -                                  $ addStats Map.empty-                                        [ ("chr",pp chr')-                                        , ("leftover sz", pp (length tlMatchY))-                                        , ("filtered out sz", pp (length tlMatchN))-                                        , ("new done sz", pp (length bDone))-                                        , ("new todo sz", pp (length bTodo))-                                        , ("wl queue sz", pp (length (wlQueue wl')))-                                        , ("wl usedin sz", pp (Map.size (wlUsedIn wl')))-                                        , ("done sz", pp (Set.size (stDoneCnstrSet st')))-                                        , ("hist cnt", pp histCount)-                                        ]-                                  $--}   -                                  st'-                              expandMatch tlMatchY--                          expandMatch _ -                            = iter-                          -                  _ -> do-                      put-{-   -                          $ addStats Map.empty-                                [ ("no match work", ppTreeTrieKey workHdKey)-                                , ("wl queue sz", pp (length (wlQueue wl')))-                                ]-                          $--}    -                          st'-                      iter-                    where wl' = wl { wlScanned = workHd : wlScanned wl, wlQueue = workTl }-                          st' = stmatch { stWorkList = wl', stTrace = SolveDbg (ppdbg) : {- -} stTrace stmatch }-              where (matches,lastQuery,ppdbg,stats) = workMatches st-{-  -                    stmatch = addStats stats [("(a) workHd", ppTreeTrieKey workHdKey), ("(b) matches", ppBracketsCommasBlock [ s `varUpd` storedChr schr | ((schr,_),s) <- matches ])]--}-                    stmatch =  -                                (st { stCountCnstr = scntInc workHdKey "workMatched" $ stCountCnstr st-                                    , stMatchCache = Map.insert workHdKey [] (stMatchCache st)-                                    , stLastQuery  = lastQuery-                                    })-            _ -> do-                return ()--        mkStats  stats new    = stats `Map.union` Map.fromList (assocLMapKey showPP new)-{--        addStats stats new st = st { stTrace = SolveStats (mkStats stats new) : stTrace st }--}-        addStats _     _   st = st--        workMatches st@(SolveState {stWorkList = WorkList {wlQueue = (workHd@(workHdKey,Work {workTime = workHdTm}) : _), wlTrie = wlTrie, wlUsedIn = wlUsedIn}, stHistoryCount = histCount, stLastQuery = lastQuery})-          | isJust mbInCache  = ( fromJust mbInCache-                                , lastQuery-                                , Pretty.empty, mkStats Map.empty [("cache sz",pp (Map.size (stMatchCache st)))]-                                )-          | otherwise         = ( r5-                                , foldr lqUnion lastQuery [ lqSingleton ck wks histCount | (_,(_,(ck,wks))) <- r23 ]-{--                                -- , Pretty.empty-                                , pp2 >-< {- pp2b >-< pp2c >-< -} pp3-                                , mkStats Map.empty [("(1) lookup sz",pp (length r2)), ("(2) cand sz",pp (length r3)), ("(3) unused cand sz",pp (length r4)), ("(4) final cand sz",pp (length r5))]--}-                                , Pretty.empty-                                , Map.empty-                                )-          where -- cache result, if present use that, otherwise the below computation-                mbInCache = Map.lookup workHdKey (stMatchCache st)-                -                -- results, stepwise computed for later reference in debugging output-                -- basic search result-                r2 :: [StoredCHR e s]                                       -- CHRs matching workHdKey-                r2  = concat                                                    -- flatten-                        $ TreeTrie.lookupResultToList                                   -- convert to list-                        $ chrTrieLookup chrLookupHowWildAtTrie workHdKey        -- lookup the store, allowing too many results-                        $ chrstoreTrie chrStore-                -                -- lookup further info in wlTrie, in particular to find out what has been done already-                r23 :: [( StoredCHR e s                                     -- the CHR-                        , ( [( [(CHRKey c, Work c)]                             -- for each CHR the list of constraints, all possible work matches-                             , [(CHRKey c, Work c)]-                             )]-                          , (CHRKey c, Set.Set (CHRKey c))-                        ) )]-                r23 = map (\c -> (c, slvCandidate workHdKey lastQuery wlTrie c)) r2-                -                -- possible matches-                r3, r4-                    :: [( StoredCHR e s                                     -- the matched CHR-                        , ( [CHRKey c]                                            -- possible matching constraints (matching with the CHR constraints), as Keys, as Works-                          , [Work c]-                        ) )]-                r3  = concatMap (\(c,cands) -> zip (repeat c) (map unzip $ slvCombine cands)) $ r23-                -                -- same, but now restricted to not used earlier as indicated by the worklist-                r4  = filter (not . slvIsUsedByPropPart wlUsedIn) r3-                -                -- finally, the 'real' match of the 'real' constraint, yielding (by tupling) substitutions instantiating the found trie matches-                r5  :: [( ( StoredCHR e s-                          , ( [CHRKey c]          -                            , [Work c]-                          ) )-                        , s-                        )]-                r5  = mapMaybe (\r@(chr,kw@(_,works)) -> fmap (\s -> (r,s)) $ slvMatch env chr (map workCnstr works)) r4-{--                -- debug info-                pp2  = "lookups"    >#< ("for" >#< ppTreeTrieKey workHdKey >-< ppBracketsCommasBlock r2)-                -- pp2b = "cand1"      >#< (ppBracketsCommasBlock $ map (ppBracketsCommasBlock . map (ppBracketsCommasBlock . map (\(k,w) -> ppTreeTrieKey k >#< w)) . fst . candidate) r2)-                -- pp2c = "cand2"      >#< (ppBracketsCommasBlock $ map (ppBracketsCommasBlock . map (ppBracketsCommasBlock) . combineToDistinguishedElts . fst . candidate) r2)-                pp3  = "candidates" >#< (ppBracketsCommasBlock $ map (\(chr,(ks,ws)) -> "chr" >#< chr >-< "keys" >#< ppBracketsCommas (map ppTreeTrieKey ks) >-< "works" >#< ppBracketsCommasBlock ws) $ r3)--}-        initState st = st { stWorkList = wlInsert (stHistoryCount st) wlnew $ stWorkList st, stDoneCnstrSet = Set.unions [Set.fromList done, stDoneCnstrSet st] }-                     where (wlnew,done) = splitDone cnstrs-        splitDone  = partition cnstrRequiresSolve-{- -}---- | 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-  :: (Ord (TTKey c), PP (TTKey c), c ~ CHRConstraint e s)-     => CHRKey c-     -> LastQuery c-     -> WorkTrie c-     -> StoredCHR e s-     -> ( [( [(CHRKey c, Work c)]-           , [(CHRKey c, Work c)]-           )]-        , (CHRKey c, Set.Set (CHRKey c))-        )-slvCandidate workHdKey lastQuery wlTrie (StoredCHR {storedIdent = (ck,_), storedKeys = ks, storedChr = chr})-  = ( map (maybe (lkup chrLookupHowExact workHdKey) (lkup chrLookupHowWildAtKey)) ks-    , ( ck-      , Set.fromList $ map (maybe workHdKey id) ks-    ) )-  where lkup how k = partition (\(_,w) -> workTime w < lastQueryTm) $ map (\w -> (workKey w,w)) $ TreeTrie.lookupResultToList $ chrTrieLookup how k wlTrie-                   where lastQueryTm = lqLookupW k $ lqLookupC ck lastQuery-{-# INLINE slvCandidate #-}----- | Check whether the CHR propagation part of a match already has been used (i.e. propagated) earlier,---   this to avoid duplicate propagation.-slvIsUsedByPropPart-  :: (Ord k, Ord (TTKey c), c ~ CHRConstraint e s)-     => Map.Map (Set.Set k) (Set.Set (UsedByKey c))-     -> (StoredCHR e s, ([k], t))-     -> Bool-slvIsUsedByPropPart wlUsedIn (chr,(keys,_))-  = fnd $ drop (storedSimpSz chr) keys-  where fnd k = maybe False (storedIdent chr `Set.member`) $ Map.lookup (Set.fromList k) wlUsedIn-{-# INLINE slvIsUsedByPropPart #-}---- | Match the stored CHR with a set of possible constraints, giving a substitution on success-slvMatch-  :: ( IsCHRSolvable e s-     )-     => e -> StoredCHR e s -> [CHRConstraint e s] -> Maybe s-slvMatch env chr cnstrs-  = foldl cmb (Just chrEmptySubst) $ matches chr cnstrs ++ checks chr-  where matches (StoredCHR {storedChr = CHRRule { chrRule = Rule {ruleHead = hc}}}) cnstrs-          = zipWith mt hc cnstrs-          where mt cFr cTo subst = chrMatchTo env subst cFr cTo-        checks (StoredCHR {storedChr = CHRRule { chrRule = Rule {ruleGuard = gd}}})-          = map chk gd-          where chk g subst = chrCheck env subst g-        cmb (Just s) next = fmap (|+> s) $ next s-        cmb _        _    = Nothing-{-# INLINE slvMatch #-}-------------------------------------------------------------------------------------------------- Instances: Serialize----------------------------------------------------------------------------------------------instance (Ord (TTKey (CHRConstraint e s)), Serialize (TTKey (CHRConstraint e s)), Serialize (CHRRule e s)) => Serialize (CHRStore e s) where-  sput (CHRStore a) = sput a-  sget = liftM CHRStore sget--instance (Serialize (CHRRule e s), Serialize (TTKey (CHRConstraint e s))) => Serialize (StoredCHR e s) where-  sput (StoredCHR a b c d) = sput a >> sput b >> sput c >> sput d-  sget = liftM4 StoredCHR sget sget sget sget--

@@ -1,4 +1,4 @@-{-# LANGUAGE UndecidableInstances, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes #-}+{-# LANGUAGE UndecidableInstances, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes #-}  ------------------------------------------------------------------------- -- Combinators for a compile run

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}  ------------------------------------------------------------------------- -- | Combinators for a compile run.

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}  ------------------------------------------------------------------------- -- | Combinators for a compile run.

@@ -0,0 +1,44 @@+-------------------------------------------------------------------------------------------+--- Freshness of something+-------------------------------------------------------------------------------------------++module UHC.Util.Fresh+  ( -- MonadFresh(..)+    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

@@ -2,7 +2,7 @@     in addition providing some of the instances for datatypes defined in the remainder of the uhc-util package. -} -{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeOperators, NoMonomorphismRestriction #-}  module UHC.Util.Lens   ( (:->)@@ -19,6 +19,7 @@   , (=.)   , (=:)   , (=$:)+  , modifyAndGet   , getl      -- * Misc@@ -27,6 +28,13 @@      , mkLabel   +  -- * Tuple accessors+  , fstl+  , sndl+  , fst3l+  , snd3l+  , trd3l+     -- * Wrappers      , isoMb@@ -41,19 +49,20 @@ import           Control.Category  import           Data.Label hiding (Lens)-import           Data.Label.Monadic((=:), (=.))+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 (:->)+-- * Textual alias for (:->), avoiding TypeOperators type Lens a b = a :-> b  -- * Operator interface for composition  infixl 9 ^*--- | composition+-- | composition with a flipped reading (^*) :: (a :-> b) -> (b :-> c) -> (a :-> c) f1 ^* f2 = f2 . f1 {-# INLINE (^*) #-}@@ -81,12 +90,21 @@  -- * 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@@ -102,6 +120,24 @@ -- | 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 

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, FlexibleContexts, CPP #-}+{-# LANGUAGE RankNTypes, CPP #-}  module UHC.Util.ParseUtils   ( -- * Specific parser types

@@ -92,6 +92,7 @@ import           UHC.Util.Time import           System.IO import           Data.List+import           Data.Word import qualified Data.Set as Set  -------------------------------------------------------------------------@@ -420,6 +421,9 @@ instance PP Bool where   pp = pp . show +instance PP Word32 where+  pp = pp . show+ instance PP ClockTime where   pp = pp . show @@ -432,10 +436,10 @@ 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) = ppParensCommasBlock [a,b,c]+  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] 

@@ -28,7 +28,7 @@   where  import System.IO-import Data.Data+-- import Data.Data import Data.Typeable  -------------------------------------------------------------------------@@ -40,7 +40,7 @@     { cchEmp :: !Bool       -- ^ is it empty     , cchSng :: !Bool       -- ^ is it a single line     }-  deriving (Typeable, Data)+  deriving (Typeable)  -- | Doc structure data Doc@@ -49,7 +49,7 @@   | Hor         !Cached !Doc  !Doc      -- horizontal positioning   | Ver         !Cached !Doc  !Doc      -- vertical positioning   | Ind         !Int !Doc               -- indent-  deriving (Typeable, Data)+  deriving (Typeable)  type PP_Doc = Doc 

@@ -119,7 +119,7 @@ #else deriving instance Typeable1 RLList #endif-deriving instance Data x => Data (RLList x)+-- deriving instance Data x => Data (RLList x)  ------------------------------------------------------------------------------------------- --- Instances: Binary, Serialize

@@ -36,10 +36,12 @@ -- | Enter a new scope enter :: Int -> LexScope -> LexScope enter x s = s `concat` singleton x+{-# INLINE enter #-}  -- | Leave a scope, if possible leave :: LexScope -> Maybe LexScope leave s = fmap fst $ initLast s+{-# INLINE leave #-}  ------------------------------------------------------------------------------------------- --- Lexical scope: observations@@ -48,6 +50,7 @@ -- | Is scope visible from other scope? isVisibleIn :: LexScope -> LexScope -> Bool isVisibleIn sOuter sInner = sOuter `isPrefixOf` sInner+{-# INLINE isVisibleIn #-}  -- | The common outer scope, which is empty if there is no common scope common :: LexScope -> LexScope -> LexScope@@ -67,3 +70,4 @@ -- | Compare by length compareByLength :: LexScope -> LexScope -> Ordering                   compareByLength s t = length s `compare` length t+{-# INLINE compareByLength #-}

@@ -19,6 +19,7 @@ import Data.Char import Data.List import qualified Data.Set as Set+import qualified Data.Map as Map  import UHC.Util.Pretty @@ -111,7 +112,7 @@ data ScanOpts   =  ScanOpts         {   scoKeywordsTxt      ::  !(Set.Set String)       -- identifiers which are keywords-        ,   scoPragmasTxt       ::  !(Set.Set String)       -- identifiers which are pragmas+        ,   scoPragmasTxt       ::  !(Map.Map String Bool)  -- identifiers which are pragmas, associated with yes/no parse remainder as string literal         ,   scoCommandsTxt      ::  !(Set.Set String)       -- identifiers which are commands         ,   scoKeywordsOps      ::  !(Set.Set String)       -- operators which are keywords         ,   scoKeywExtraChars   ::  !(Set.Set Char)         -- extra chars to be used by identifiers@@ -135,7 +136,7 @@ defaultScanOpts   =  ScanOpts         {   scoKeywordsTxt      =   Set.empty-        ,   scoPragmasTxt       =   Set.empty+        ,   scoPragmasTxt       =   Map.empty         ,   scoCommandsTxt      =   Set.empty         ,   scoKeywordsOps      =   Set.empty         ,   scoKeywExtraChars   =   Set.empty

@@ -61,7 +61,7 @@ import UHC.Util.AssocL -- import EH100.Base.Common import Data.Typeable (Typeable)-import Data.Generics (Data)+-- import Data.Generics (Data) import UHC.Util.Serialize import Control.Monad -- import EH100.Base.Binary@@ -75,7 +75,7 @@       { sgeScpId    :: !Int                         -- ^ scope ident       , sgeVal      :: v                            -- ^ the value       }-  deriving (Typeable, Data, Generic)+  deriving (Typeable, Generic)  type SMap k v = VarMp' k [SGamElt v] @@ -88,7 +88,7 @@       , sgScp       :: !Scp                         -- ^ scope stack       , sgMap       :: SMap k v                     -- ^ map holding the values       }-  deriving (Typeable, Data, Generic)+  deriving (Typeable, Generic)  mkSGam :: SMap k v -> SGam k v mkSGam = SGam 0 [0]@@ -179,11 +179,11 @@ sgamMap f g = sgamMapEltWithKey (\k e -> let (k',v') = f (k,sgeVal e) in (k',e {sgeVal = v'})) g  -- | Construct singleton gam, on a particular meta level-sgamMetaLevSingleton :: MetaLev -> k -> v -> SGam k v-sgamMetaLevSingleton mlev k v = mkSGam (varmpMetaLevSingleton mlev k [SGamElt 0 v])+sgamMetaLevSingleton :: Ord k => MetaLev -> k -> v -> SGam k v+sgamMetaLevSingleton mlev k v = mkSGam (varlookupSingletonWithMetaLev mlev k [SGamElt 0 v])  -- | Construct singleton gam-sgamSingleton :: k -> v -> SGam k v+sgamSingleton :: Ord k => k -> v -> SGam k v sgamSingleton = sgamMetaLevSingleton metaLevVal  -- | combine gam, g1 is added to g2 with scope of g2

@@ -0,0 +1,592 @@+{- |+A VarMp maps from variables (tvars, ...) to whatever else has to be+mapped to (Ty, ...).++Starting with variant 6 (which introduces kinds) it allows multiple meta+level mapping, in that the VarMp holds mappings for multiple meta+levels. This allows one map to both map to base level info and to higher+levels. In particular this is used by fitsIn which also instantiates+types, and types may quantify over type variables with other kinds than+kind *, which must be propagated. A separate map could have been used,+but this holds the info together and is extendible to more levels.++A multiple level VarMp knows its own absolute metalevel, which is the default to use for lookup.+-}++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- {-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE DeriveGeneric #-}++module UHC.Util.ScopeVarMp+    ( 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+    )+  where++import           Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import           Data.Maybe+import           UHC.Util.Pretty+import           UHC.Util.AssocL+import           UHC.Util.VarLookup+import           UHC.Util.Utils+import           Control.Monad+import           Data.Typeable (Typeable)+import           UHC.Util.Serialize+++++-- | Scope identification+type ScpId = Int++-- | Scope stack: a collection of stacks with entry points identified by 'ScpId'++data VarMp' k v+  = VarMp+      { varmpMetaLev    :: !MetaLev             -- ^ the base meta level+      -- , varmpScpStk     :: !(Map+      , 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+  -- sget = liftM2 VarMp sget sget+

@@ -1,13 +1,17 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+-------------------------------------------------------------------------------------------+--- Substitution abilities+------------------------------------------------------------------------------------------- +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}+ module UHC.Util.Substitutable   (     VarUpdatable(..)   , VarExtractable(..)   -  , SubstVarKey-  , SubstVarVal   , ExtrValVarKey+  +  , VarTerm(..)   )   where @@ -15,29 +19,75 @@ import           UHC.Util.VarMp  ----------------------------------------------------------------------------------------------- Substitutable classes+--- Misc -------------------------------------------------------------------------------------------  infixr 6 `varUpd` infixr 6 `varUpdCyc` --- | Invariant: SubstVarKey subst = ExtrValVarKey (SubstVarVal subst)-type family SubstVarKey subst :: *-type family SubstVarVal subst :: *+-- | The variable wich is used as a key into a substitution type family ExtrValVarKey vv :: * -type instance ExtrValVarKey [vv] = ExtrValVarKey vv+-------------------------------------------------------------------------------------------+--- Updatable+------------------------------------------------------------------------------------------- -class VarUpdatable vv subst where -- skey sval | subst -> skey sval where+-- | Term in which variables can be updated with a subst(itution)+class VarUpdatable vv subst where+  -- | Update   varUpd            ::  subst -> vv -> vv-  varUpdCyc         ::  subst -> vv -> (vv, VarMp' (SubstVarKey subst) (SubstVarVal subst))-  s `varUpdCyc` x = (s `varUpd` x,emptyVarMp)+  -- s `varUpd` x = let (x',_) = s `varUpdCyc` x in x+  -- {-# INLINE varUpd #-} -class Ord (ExtrValVarKey vv) => VarExtractable vv where -- k | vv -> k where+  -- | 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]-  varFreeSet        ::  vv -> Set.Set (ExtrValVarKey vv)-  -  -- default   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+  + 

@@ -86,7 +86,7 @@ import qualified UHC.Util.Pretty as PP import           Control.Monad import           Data.Typeable(Typeable)-import           Data.Generics(Data)+-- import           Data.Generics(Data) import           UHC.Util.Serialize  -------------------------------------------------------------------------------------------@@ -120,12 +120,12 @@ deriving instance Typeable1 TreeTrie1Key deriving instance Typeable1 TreeTrieMp1Key #endif-deriving instance Data x => Data (TreeTrie1Key x) -deriving instance Data x => Data (TreeTrieMp1Key x) +-- 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+  show (TT1K_One k) = "(1:" ++ show k ++ ")"  instance Show k => Show (TreeTrieMp1Key k) where   show (TTM1K_Any )  = "**" -- ++ show i@@ -133,7 +133,7 @@  instance PP k => PP (TreeTrie1Key k) where   pp  TT1K_Any    = pp "*"-  pp (TT1K_One k) = "1:" >|< k+  pp (TT1K_One k) = ppParens $ "1:" >|< k  instance PP k => PP (TreeTrieMp1Key k) where   pp = ppTreeTrieMp1Key@@ -242,7 +242,7 @@       { ttrieMbVal       :: Maybe v                                                 -- value       , ttrieSubs        :: TreeTrieChildren k v                                    -- children       }- deriving (Typeable, Data)+ deriving (Typeable)  emptyTreeTrie, empty :: TreeTrie k v emptyTreeTrie = TreeTrie Nothing Map.empty@@ -347,9 +347,9 @@                      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+                                     []                             -> l id (res mkRes k) [] t+                                     (_:_) | 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@@ -652,14 +652,14 @@       ]  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"]]-		]+        [[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"]]+        ]             

@@ -0,0 +1,825 @@+{-# 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]>+  ]++-}

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances, DefaultSignatures, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances, DefaultSignatures, UndecidableInstances #-}  module UHC.Util.Utils   ( -- * Set@@ -21,6 +21,9 @@   , listSaturate, listSaturateWith   , spanOnRest   , filterMb+  , splitPlaces+  , combineToDistinguishedEltsBy+  , partitionOnSplit        -- * Tuple   , tup123to1, tup123to2@@ -72,6 +75,10 @@   , DataAndConName(..)   , showUnprefixed   +    -- * Ordering+  , orderingLexic+  , orderingLexicList+       -- * Misc   , panic   @@ -89,8 +96,6 @@      , partitionAndRebuild   -  , orderingLexic-       -- * Maybe   , panicJust   , ($?)@@ -111,6 +116,7 @@ import Data.Char import Data.List import Data.Maybe+import Data.Function import Data.Typeable import GHC.Generics import qualified Data.Set as Set@@ -225,6 +231,45 @@ filterMb p = catMaybes . map p {-# INLINE filterMb #-} +-- | Split at index places (inspired by/from split package). Places should be increasing, starting with an index >= 0.+-- The number of sublists returned is one higher than the number of places.+-- +-- Examples:+-- >>> splitPlaces [2,3] [1,2,3,4,5,6,7] +-- [[1,2],[3],[4,5,6,7]]+--+-- >>> splitPlaces [6,7] [1,2,3,4,5,6,7] +-- [[1,2,3,4,5,6],[7],[]]+--+-- >>> splitPlaces [0,7] [1,2,3,4,5,6,7]+-- [[],[1,2,3,4,5,6,7],[]]+--+-- >>> splitPlaces [0,1,2,3,4,5,6,7] [1,2,3,4,5,6,7] +-- [[],[1],[2],[3],[4],[5],[6],[7],[]]+splitPlaces+  :: [Int]            -- ^ places+  -> [e]+  -> [[e]]+splitPlaces ps es = spl 0 ps es+  where spl _   []     es = [es]+        spl pos (p:ps) es = es1 : spls+          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]]+combineToDistinguishedEltsBy _  []     = []+combineToDistinguishedEltsBy _  [[]]   = []+combineToDistinguishedEltsBy _  [x]    = map (:[]) x+combineToDistinguishedEltsBy eq (l:ls)+  = combine l $ combineToDistinguishedEltsBy eq ls+  where combine l ls+          = concatMap (\e+                         -> mapMaybe (\ll -> maybe (Just (e:ll)) (const Nothing) $ find (eq e) ll)+                                     ls+                      ) l+ ------------------------------------------------------------------------- -- Tupling, untupling -------------------------------------------------------------------------@@ -413,22 +458,22 @@ #endif  sortByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> [a]-sortByOn cmp sel = sortBy (\e1 e2 -> sel e1 `cmp` sel e2)+sortByOn cmp sel = sortBy (cmp `on` sel) -- (\e1 e2 -> sel e1 `cmp` sel e2)  groupOn :: Eq b => (a -> b) -> [a] -> [[a]]-groupOn sel = groupBy (\e1 e2 -> sel e1 == sel e2)+groupOn sel = groupBy ((==) `on` sel) -- (\e1 e2 -> sel e1 == sel e2)  groupSortOn :: Ord b => (a -> b) -> [a] -> [[a]] groupSortOn sel = groupOn sel . sortOn sel  groupByOn :: (b -> b -> Bool) -> (a -> b) -> [a] -> [[a]]-groupByOn eq sel = groupBy (\e1 e2 -> sel e1 `eq` sel e2)+groupByOn eq sel = groupBy (eq `on` sel) -- (\e1 e2 -> sel e1 `eq` sel e2)  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 (\a1 a2 -> sel a1 == sel a2)+nubOn sel = nubBy ((==) `on` sel) -- (\a1 a2 -> sel a1 == sel a2)  -- | The 'consecutiveBy' function groups like groupBy, but based on a function which says whether 2 elements are consecutive consecutiveBy                  :: (a -> a -> Bool) -> [a] -> [[a]]@@ -439,6 +484,23 @@         consec x yys@(y:ys) | isConsec x y = let (yys',zs) = consec y ys in (x:yys',zs)                             | otherwise    = ([x],yys) +-- | Partition on part of something, yielding a something else in the partitioning+partitionOnSplit :: (a -> (x,y)) -> (x -> x') -> (x -> Bool) -> [a] -> ([(x',y)],[y])+partitionOnSplit split adapt pred xs = foldr sel ([],[]) xs+  where sel x ~(ts,fs) | pred x'   = ((adapt x',y):ts,   fs)+                       | otherwise = (             ts, y:fs)+          where (x',y) = split x++{-+partition               :: (a -> Bool) -> [a] -> ([a],[a])+{-# INLINE partition #-}+partition p xs = foldr (select p) ([],[]) xs++select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])+select p x ~(ts,fs) | p x       = (x:ts,fs)+                    | otherwise = (ts, x:fs)+-}+ ------------------------------------------------------------------------- -- Partitioning with rebuild -------------------------------------------------------------------------@@ -456,8 +518,14 @@ -------------------------------------------------------------------------  -- | Reduce compare results lexicographically to one compare result-orderingLexic :: [Ordering] -> Ordering-orderingLexic = foldr1 (\o1 o2 -> if o1 == EQ then o2 else o1)+orderingLexicList :: [Ordering] -> Ordering+orderingLexicList = foldr1 orderingLexic+{-# INLINE orderingLexicList #-}++-- | Reduce compare results lexicographically using a continuation ordering+orderingLexic :: Ordering -> Ordering -> Ordering+orderingLexic o1 o2 = if o1 == EQ then o2 else o1+{-# INLINE orderingLexic #-}  ------------------------------------------------------------------------- -- Maybe