diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/src/UHC/Util/AssocL.hs b/src/UHC/Util/AssocL.hs --- a/src/UHC/Util/AssocL.hs +++ b/src/UHC/Util/AssocL.hs @@ -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 #-} diff --git a/src/UHC/Util/Binary.hs b/src/UHC/Util/Binary.hs --- a/src/UHC/Util/Binary.hs +++ b/src/UHC/Util/Binary.hs @@ -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 - +-} diff --git a/src/UHC/Util/CHR/Base.hs b/src/UHC/Util/CHR/Base.hs --- a/src/UHC/Util/CHR/Base.hs +++ b/src/UHC/Util/CHR/Base.hs @@ -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 --} diff --git a/src/UHC/Util/CHR/GTerm.hs b/src/UHC/Util/CHR/GTerm.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/CHR/GTerm.hs @@ -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 + + diff --git a/src/UHC/Util/CHR/GTerm/AST.hs b/src/UHC/Util/CHR/GTerm/AST.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/CHR/GTerm/AST.hs @@ -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) diff --git a/src/UHC/Util/CHR/GTerm/Parser.hs b/src/UHC/Util/CHR/GTerm/Parser.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/CHR/GTerm/Parser.hs @@ -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 ":" + + diff --git a/src/UHC/Util/CHR/Key.hs b/src/UHC/Util/CHR/Key.hs --- a/src/UHC/Util/CHR/Key.hs +++ b/src/UHC/Util/CHR/Key.hs @@ -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 diff --git a/src/UHC/Util/CHR/Rule.hs b/src/UHC/Util/CHR/Rule.hs --- a/src/UHC/Util/CHR/Rule.hs +++ b/src/UHC/Util/CHR/Rule.hs @@ -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 diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/AST.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/AST.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/AST.hs @@ -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 + diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/Main.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/Main.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/CHR/Solve/TreeTrie/Examples/Term/Main.hs @@ -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' + + +{- +-} diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Internal.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Internal.hs --- a/src/UHC/Util/CHR/Solve/TreeTrie/Internal.hs +++ b/src/UHC/Util/CHR/Solve/TreeTrie/Internal.hs @@ -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 diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Internal/Shared.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Internal/Shared.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/CHR/Solve/TreeTrie/Internal/Shared.hs @@ -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 ] + diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs --- a/src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs +++ b/src/UHC/Util/CHR/Solve/TreeTrie/Mono.hs @@ -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 diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/MonoBacktrackPrio.hs b/src/UHC/Util/CHR/Solve/TreeTrie/MonoBacktrackPrio.hs --- a/src/UHC/Util/CHR/Solve/TreeTrie/MonoBacktrackPrio.hs +++ b/src/UHC/Util/CHR/Solve/TreeTrie/MonoBacktrackPrio.hs @@ -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 diff --git a/src/UHC/Util/CHR/Solve/TreeTrie/Poly.hs b/src/UHC/Util/CHR/Solve/TreeTrie/Poly.hs deleted file mode 100644 --- a/src/UHC/Util/CHR/Solve/TreeTrie/Poly.hs +++ /dev/null @@ -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 - - diff --git a/src/UHC/Util/CompileRun.hs b/src/UHC/Util/CompileRun.hs --- a/src/UHC/Util/CompileRun.hs +++ b/src/UHC/Util/CompileRun.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes #-} +{-# LANGUAGE UndecidableInstances, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes #-} ------------------------------------------------------------------------- -- Combinators for a compile run diff --git a/src/UHC/Util/CompileRun2.hs b/src/UHC/Util/CompileRun2.hs --- a/src/UHC/Util/CompileRun2.hs +++ b/src/UHC/Util/CompileRun2.hs @@ -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. diff --git a/src/UHC/Util/CompileRun3.hs b/src/UHC/Util/CompileRun3.hs --- a/src/UHC/Util/CompileRun3.hs +++ b/src/UHC/Util/CompileRun3.hs @@ -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. diff --git a/src/UHC/Util/Fresh.hs b/src/UHC/Util/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/Fresh.hs @@ -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 diff --git a/src/UHC/Util/Lens.hs b/src/UHC/Util/Lens.hs --- a/src/UHC/Util/Lens.hs +++ b/src/UHC/Util/Lens.hs @@ -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 diff --git a/src/UHC/Util/ParseUtils.hs b/src/UHC/Util/ParseUtils.hs --- a/src/UHC/Util/ParseUtils.hs +++ b/src/UHC/Util/ParseUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, FlexibleContexts, CPP #-} +{-# LANGUAGE RankNTypes, CPP #-} module UHC.Util.ParseUtils ( -- * Specific parser types diff --git a/src/UHC/Util/Pretty.hs b/src/UHC/Util/Pretty.hs --- a/src/UHC/Util/Pretty.hs +++ b/src/UHC/Util/Pretty.hs @@ -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] diff --git a/src/UHC/Util/PrettySimple.hs b/src/UHC/Util/PrettySimple.hs --- a/src/UHC/Util/PrettySimple.hs +++ b/src/UHC/Util/PrettySimple.hs @@ -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 diff --git a/src/UHC/Util/RLList.hs b/src/UHC/Util/RLList.hs --- a/src/UHC/Util/RLList.hs +++ b/src/UHC/Util/RLList.hs @@ -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 diff --git a/src/UHC/Util/RLList/LexScope.hs b/src/UHC/Util/RLList/LexScope.hs --- a/src/UHC/Util/RLList/LexScope.hs +++ b/src/UHC/Util/RLList/LexScope.hs @@ -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 #-} diff --git a/src/UHC/Util/ScanUtils.hs b/src/UHC/Util/ScanUtils.hs --- a/src/UHC/Util/ScanUtils.hs +++ b/src/UHC/Util/ScanUtils.hs @@ -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 diff --git a/src/UHC/Util/ScopeMapGam.hs b/src/UHC/Util/ScopeMapGam.hs --- a/src/UHC/Util/ScopeMapGam.hs +++ b/src/UHC/Util/ScopeMapGam.hs @@ -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 diff --git a/src/UHC/Util/ScopeVarMp.hs b/src/UHC/Util/ScopeVarMp.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/ScopeVarMp.hs @@ -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 + diff --git a/src/UHC/Util/Substitutable.hs b/src/UHC/Util/Substitutable.hs --- a/src/UHC/Util/Substitutable.hs +++ b/src/UHC/Util/Substitutable.hs @@ -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 + + diff --git a/src/UHC/Util/TreeTrie.hs b/src/UHC/Util/TreeTrie.hs --- a/src/UHC/Util/TreeTrie.hs +++ b/src/UHC/Util/TreeTrie.hs @@ -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"]] + ] diff --git a/src/UHC/Util/TreeTrie2.hs b/src/UHC/Util/TreeTrie2.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Util/TreeTrie2.hs @@ -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,,??) + ==> + (m_10_0 == (m_11_0 | ...)) \ l_12_0@off_13_0 + | [ Prove (m_11_0\l_12_0,,??) + , Red (m_10_0\l_12_0,,??) < label l_12_0@off_13_0 < [(m_11_0\l_12_0,,??)]] + , Prove ({||}\l_12_0,,??) + ==> + Red ({||}\l_12_0,,??) < label l_12_0@0 < []] + + [<[1:S:Prf]>,<[1:S:occ]>,<[1:S:[0,0],1:S:\]>,<[],[1:H:3]>,<[1:U:3_48_0_0,1:U:3_48_0_1]>]: 1 + +-} + +{- +test2 + = fromListByKey + [ ( [ [TTM1K [TT1K_One "P"]] + , [TTM1K [TT1K_One "O"]] + , [TTM1K [TT1K_Any, TT1K_One "SL"]] + , [TTM1K [], TTM1K [TT1K_Any]] + ] + , "P (O * (SL *))" + ) + ] + +l1t2 = lookupPartialByKey' (,) TTL_WildInTrie + [ [TTM1K [TT1K_One "P"]] + , [TTM1K [TT1K_One "O"]] + , [TTM1K [TT1K_One "Sc", TT1K_One "SL"]] + , [TTM1K [], TTM1K [TT1K_One "3"]] + , [TTM1K [TT1K_One "3_48_0_0", TT1K_One "3_48_0_1"]] + ] + +-} + +{- +test3 + = fromListByKey + [ ( [[TTM1K [TT1K_One "1:S:Prf"]] + ,[TTM1K [TT1K_One "1:S:occ"]] + ,[TTM1K [TT1K_Any, TT1K_One "1:H:Language.UHC.JS.ECMA.Types.ToJS"]] + ,[TTM1K [], TTM1K [TT1K_One "1:H:UHC.Base.Maybe",TT1K_Any]] + ,[TTM1K [TT1K_Any], TTM1K []] + ] + , "xx" + ) + ] + +l1t3 = lookupPartialByKey' (,) TTL_WildInTrie + [[TTM1K [TT1K_One "1:S:Prf"]] + ,[TTM1K [TT1K_One "1:S:occ"]] + ,[TTM1K [TT1K_One "1:S:[0,0,0,0,0,0]", TT1K_One "1:H:Language.UHC.JS.ECMA.Types.ToJS"]] + ,[TTM1K [],TTM1K [TT1K_One "1:H:UHC.Base.Maybe", TT1K_One "1:H:Language.UHC.JS.ECMA.Types.JSAny"]] + ,[TTM1K [TT1K_One "1:H:Language.UHC.JS.ECMA.Types.JSAny"], TTM1K [TT1K_One "1:U:12_398_1_0"]] + ,[TTM1K [TT1K_One "1:H:Language.UHC.JS.ECMA.Types.JSObject_"], TTM1K []] + ,[TTM1K [TT1K_One "1:H:Language.UHC.JS.W3C.HTML5.NodePtr"]] + ] + + + +-} + +{- + , [<[1:S:Prf]> + ,<[1:S:occ]> + ,<[*,1:H:Language.UHC.JS.ECMA.Types.ToJS]> + ,<[],[1:H:UHC.Base.Maybe,*]> + ,<[*],[]> + ] + +, DBG lookups for + [<[1:S:Prf]> + ,<[1:S:occ]> + ,<[1:S:[0,0,0,0,0,0],1:H:Language.UHC.JS.ECMA.Types.ToJS]> + ,<[],[1:H:UHC.Base.Maybe,1:H:Language.UHC.JS.ECMA.Types.JSAny]> + ,<[1:H:Language.UHC.JS.ECMA.Types.JSAny],[1:U:12_398_1_0]> + ,<[1:H:Language.UHC.JS.ECMA.Types.JSObject_],[]> + ,<[1:H:Language.UHC.JS.W3C.HTML5.NodePtr]> + ] + +-} diff --git a/src/UHC/Util/Utils.hs b/src/UHC/Util/Utils.hs --- a/src/UHC/Util/Utils.hs +++ b/src/UHC/Util/Utils.hs @@ -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 diff --git a/src/UHC/Util/VarLookup.hs b/src/UHC/Util/VarLookup.hs --- a/src/UHC/Util/VarLookup.hs +++ b/src/UHC/Util/VarLookup.hs @@ -1,30 +1,54 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 710 #else {-# LANGUAGE OverlappingInstances #-} #endif +-- | Abstractions for looking up (type) variables in structures + module UHC.Util.VarLookup - ( VarLookup (..) + ( VarLookup(..) + , VarLookupKey + , VarLookupVal + + , varlookupResolveVarWithMetaLev + , varlookupResolveVar + , varlookupResolveValWithMetaLev + , varlookupResolveVal + + -- , VarCompareHow(..) + , varlookupMap + + , varlookupResolveAndContinueM + , VarLookupFix, varlookupFix , varlookupFixDel + , VarLookupCmb (..) - , VarLookupBase (..) + + -- , VarLookupBase (..) + , VarLookupCmbFix, varlookupcmbFix , MetaLev , metaLevVal + + , StackedVarLookup(..) + ) where --- import EH100.Base.Common -import Data.Maybe +import Control.Applicative +import Data.Maybe +import UHC.Util.Pretty +import qualified Data.Set as Set +------------------------------------------------------------------------------------------- +--- Level of lookup +------------------------------------------------------------------------------------------- + -- | Level to lookup into type MetaLev = Int @@ -32,6 +56,16 @@ metaLevVal :: MetaLev metaLevVal = 0 +------------------------------------------------------------------------------------------- +--- VarLookup: something which can lookup a value 'v' given a key 'k'. +------------------------------------------------------------------------------------------- + + +-- | Type family for key of a VarLookup +type family VarLookupKey m :: * +-- | Type family for value of a VarLookup +type family VarLookupVal m :: * + {- | VarLookup abstracts from a Map. The purpose is to be able to combine maps only for the purpose of searching without actually merging the maps. @@ -39,38 +73,88 @@ The class interface serves to hide this. -} -class VarLookup m k v where - varlookupWithMetaLev :: MetaLev -> k -> m -> Maybe v - varlookup :: k -> m -> Maybe v +class VarLookup m where + -- | Lookup a key at a level + varlookupWithMetaLev :: MetaLev -> VarLookupKey m -> m -> Maybe (VarLookupVal m) - -- defaults - varlookup = varlookupWithMetaLev 0 + -- | Lookup a key + varlookup :: VarLookupKey m -> m -> Maybe (VarLookupVal m) + varlookup = varlookupWithMetaLev metaLevVal + {-# INLINE varlookup #-} + + -- | Keys at a level + varlookupKeysSetWithMetaLev :: (Ord (VarLookupKey m)) => MetaLev -> m -> Set.Set (VarLookupKey m) + + -- | Keys as Set + varlookupKeysSet :: (Ord (VarLookupKey m)) => m -> Set.Set (VarLookupKey m) + varlookupKeysSet = varlookupKeysSetWithMetaLev metaLevVal + {-# INLINE varlookupKeysSet #-} -instance (VarLookup m1 k v,VarLookup m2 k v) => VarLookup (m1,m2) k v where - varlookupWithMetaLev l k (m1,m2) - = case varlookupWithMetaLev l k m1 of - r@(Just _) -> r - _ -> varlookupWithMetaLev l k m2 + -- | Make an empty VarLookup + varlookupEmpty :: m + -- | Make a singleton VarLookup at a level + varlookupSingletonWithMetaLev :: MetaLev -> VarLookupKey m -> VarLookupVal m -> m + + -- | Make a singleton VarLookup + varlookupSingleton :: VarLookupKey m -> VarLookupVal m -> m + varlookupSingleton = varlookupSingletonWithMetaLev metaLevVal + {-# INLINE varlookupSingleton #-} -instance VarLookup m k v => VarLookup [m] k v where - varlookupWithMetaLev l k ms = listToMaybe $ catMaybes $ map (varlookupWithMetaLev l k) ms +------------------------------------------------------------------------------------------- +--- Util/convenience +------------------------------------------------------------------------------------------- -varlookupMap :: VarLookup m k v => (v -> Maybe res) -> k -> m -> Maybe res -varlookupMap get k m - = do { v <- varlookup k m - ; get v - } +-- | Combine lookup with map; should be obsolete... +varlookupMap :: VarLookup m => (VarLookupVal m -> Maybe res) -> VarLookupKey m -> m -> Maybe res +varlookupMap get k m = varlookup k m >>= get +{-# INLINE varlookupMap #-} +------------------------------------------------------------------------------------------- +--- Lookup and resolution +------------------------------------------------------------------------------------------- + +-- | Fully resolve lookup +varlookupResolveVarWithMetaLev :: VarLookup m => MetaLev -> (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupKey m -> m -> Maybe (VarLookupVal m) +varlookupResolveVarWithMetaLev l isVar k m = + varlookupWithMetaLev l k m >>= \v -> varlookupResolveValWithMetaLev l isVar v m <|> return v + +-- | Fully resolve lookup +varlookupResolveVar :: VarLookup m => (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupKey m -> m -> Maybe (VarLookupVal m) +varlookupResolveVar = varlookupResolveVarWithMetaLev metaLevVal +{-# INLINE varlookupResolveVar #-} + +varlookupResolveValWithMetaLev :: VarLookup m => MetaLev -> (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupVal m -> m -> Maybe (VarLookupVal m) +varlookupResolveValWithMetaLev l isVar v m = isVar v >>= \k -> varlookupResolveVarWithMetaLev l isVar k m <|> return v + +-- | Fully resolve lookup +varlookupResolveVal :: VarLookup m => (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupVal m -> m -> Maybe (VarLookupVal m) +varlookupResolveVal = varlookupResolveValWithMetaLev metaLevVal +{-# INLINE varlookupResolveVal #-} + +-- | Monadically lookup a variable, resolve it, continue with either a fail or success monad continuation +varlookupResolveAndContinueM :: (Monad m, VarLookup s) => (VarLookupVal s -> Maybe (VarLookupKey s)) -> (m s) -> (m a) -> (VarLookupVal s -> m a) -> VarLookupKey s -> m a +varlookupResolveAndContinueM tmIsVar gets failFind okFind k = gets >>= \s -> maybe failFind okFind $ varlookupResolveVar tmIsVar k s + +------------------------------------------------------------------------------------------- +--- VarLookupFix +------------------------------------------------------------------------------------------- + +-- (not yet, still in use in UHC) {-# DEPRECATED VarLookupFix, varlookupFix, varlookupFixDel "As of 20160331: don't use these anymore" #-} + type VarLookupFix k v = k -> Maybe v -- | fix looking up to be for a certain var mapping -varlookupFix :: VarLookup m k v => m -> VarLookupFix k v +varlookupFix :: VarLookup m => m -> VarLookupFix (VarLookupKey m) (VarLookupVal m) varlookupFix m = \k -> varlookup k m -- | simulate deletion varlookupFixDel :: Ord k => [k] -> VarLookupFix k v -> VarLookupFix k v varlookupFixDel ks f = \k -> if k `elem` ks then Nothing else f k +------------------------------------------------------------------------------------------- +--- VarLookupCmb: combine VarLookups +------------------------------------------------------------------------------------------- + {- | VarLookupCmb abstracts the 'combining' of/from a substitution. The interface goes along with VarLookup but is split off to avoid functional dependency restrictions. @@ -78,11 +162,12 @@ This then avoids the later need to unmerge such mergings. -} -infixr 7 |+> - class VarLookupCmb m1 m2 where (|+>) :: m1 -> m2 -> m2 +infixr 7 |+> + +{- #if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPING #-} #else @@ -90,7 +175,9 @@ #endif VarLookupCmb m1 m2 => VarLookupCmb m1 [m2] where m1 |+> (m2:m2s) = (m1 |+> m2) : m2s +-} +{- #if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPING #-} #else @@ -98,14 +185,64 @@ #endif (VarLookupCmb m1 m1, VarLookupCmb m1 m2) => VarLookupCmb [m1] [m2] where m1 |+> (m2:m2s) = (foldr1 (|+>) m1 |+> m2) : m2s +-} -class VarLookupBase m k v | m -> k v where - varlookupEmpty :: m - -- varlookupTyUnit :: k -> v -> m +{- +instance + (VarLookupCmb m1 m1, VarLookupCmb m1 m2) => VarLookupCmb (StackedVarLookup m1) (StackedVarLookup m2) where + m1 |+> StackedVarLookup (m2:m2s) = StackedVarLookup $ (foldr1 (|+>) m1 |+> m2) : m2s +-} +------------------------------------------------------------------------------------------- +--- How to do the VarLookup part of matching/unification/comparing +------------------------------------------------------------------------------------------- + +{- +-- | How to match, increasingly more binding is allowed +data VarCompareHow + = VarCompareHow_Check -- ^ equality check only + | VarCompareHow_Match -- ^ also allow one-directional (left to right) matching/binding of (meta)vars + | VarCompareHow_MatchAndWait -- ^ also allow giving back of global vars on which we wait + | VarCompareHow_Unify -- ^ also allow bi-directional matching, i.e. unification + deriving (Ord, Eq) +-} + +------------------------------------------------------------------------------------------- +--- VarLookupCmbFix +------------------------------------------------------------------------------------------- + +{-# DEPRECATED VarLookupCmbFix, varlookupcmbFix "As of 20160331: don't use these anymore" #-} type VarLookupCmbFix m1 m2 = m1 -> m2 -> m2 -- | fix combining up to be for a certain var mapping varlookupcmbFix :: VarLookupCmb m1 m2 => VarLookupCmbFix m1 m2 varlookupcmbFix m1 m2 = m1 |+> m2 + +------------------------------------------------------------------------------------------- +--- Stack of things in which we can lookup, but which is updated only at the top +------------------------------------------------------------------------------------------- + +-- | Stacked VarLookup derived from a base one, to allow a use of multiple lookups but update on top only +newtype StackedVarLookup s = StackedVarLookup {unStackedVarLookup :: [s]} + deriving Foldable + +type instance VarLookupKey (StackedVarLookup s) = VarLookupKey s +type instance VarLookupVal (StackedVarLookup s) = VarLookupVal s + +instance Show (StackedVarLookup s) where + show _ = "StackedVarLookup" + +instance PP s => PP (StackedVarLookup s) where + pp (StackedVarLookup xs) = ppCurlysCommas $ map pp xs + +instance (VarLookup m) => VarLookup (StackedVarLookup m) where + varlookupWithMetaLev l k (StackedVarLookup ms) = listToMaybe $ catMaybes $ map (varlookupWithMetaLev l k) ms + varlookupKeysSetWithMetaLev l (StackedVarLookup ms) = Set.unions $ map (varlookupKeysSetWithMetaLev l) ms + varlookupEmpty = StackedVarLookup [varlookupEmpty] + {-# INLINE varlookupEmpty #-} + varlookupSingletonWithMetaLev l k v = StackedVarLookup [varlookupSingletonWithMetaLev l k v] + {-# INLINE varlookupSingletonWithMetaLev #-} + +instance VarLookupCmb m1 m2 => VarLookupCmb m1 (StackedVarLookup m2) where + m1 |+> StackedVarLookup (m2:m2s) = StackedVarLookup $ (m1 |+> m2) : m2s diff --git a/src/UHC/Util/VarMp.hs b/src/UHC/Util/VarMp.hs --- a/src/UHC/Util/VarMp.hs +++ b/src/UHC/Util/VarMp.hs @@ -56,11 +56,13 @@ , varmpAsMap , varmpMapMaybe, varmpMap , varmpInsertWith +{- , VarMpStk' , emptyVarMpStk, varmpstkUnit , varmpstkPushEmpty, varmpstkPop , varmpstkToAssocL, varmpstkKeysSet , varmpstkUnions +-} , varmpSize -- , vmiMbImpls, vmiMbScope, vmiMbPred, vmiMbAssNm -- , varmpTailAddOcc @@ -98,7 +100,7 @@ import UHC.Util.Utils import Control.Monad import Data.Typeable (Typeable) -import Data.Generics (Data) +-- import Data.Generics (Data) -- import EH100.Base.Binary import UHC.Util.Serialize @@ -112,26 +114,27 @@ { varmpMetaLev :: !MetaLev -- ^ the base meta level , varmpMpL :: [Map.Map k v] -- ^ for each level a map, starting at the base meta level } - deriving ( Eq, Ord - , Typeable, Data, Generic - ) + 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 -instance VarLookupBase (VarMp' k v) k v where - varlookupEmpty = emptyVarMp - varmpFilter :: Ord k => (k -> v -> Bool) -> VarMp' k v -> VarMp' k v varmpFilter f (VarMp l c) = VarMp l (map (Map.filterWithKey f) c) @@ -183,16 +186,20 @@ varmpKeysSet :: Ord k => VarMp' k v -> Set.Set k varmpKeysSet (VarMp _ fm) = Set.unions $ map Map.keysSet fm --- VarMp construction - -varmpMetaLevSingleton :: MetaLev -> k -> v -> VarMp' k v -varmpMetaLevSingleton mlev k v = VarMp mlev [Map.singleton k v] +{-# DEPRECATED varmpMetaLevSingleton "Use varlookupSingletonWithMetaLev" #-} +-- | VarMp singleton +varmpMetaLevSingleton :: Ord k => MetaLev -> k -> v -> VarMp' k v +varmpMetaLevSingleton = varlookupSingletonWithMetaLev +{-# INLINE varmpMetaLevSingleton #-} -varmpSingleton :: k -> v -> VarMp' k v -varmpSingleton = varmpMetaLevSingleton metaLevVal +-- (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 [ varmpMetaLevSingleton lev k v | (k,(lev,v)) <- l ] +assocMetaLevLToVarMp l = varmpUnions [ varlookupSingletonWithMetaLev lev k v | (k,(lev,v)) <- l ] assocLToVarMp :: Ord k => AssocL k v -> VarMp' k v assocLToVarMp = mkVarMp . Map.fromList @@ -255,12 +262,18 @@ -- Lookup as VarLookup -instance Ord k => VarLookup (VarMp' k v) k v where +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 @@ -355,7 +368,7 @@ _ -> mkTyVar v -- rest incomplete varmpMetaLevTyUnit :: Ord k => MetaLev -> k -> Ty -> VarMp' k VarMpInfo -varmpMetaLevTyUnit mlev v t = varmpMetaLevSingleton mlev v (VMITy t) +varmpMetaLevTyUnit mlev v t = varlookupSingletonWithMetaLev mlev v (VMITy t) varmpTyUnit :: Ord k => k -> Ty -> VarMp' k VarMpInfo varmpTyUnit = varmpMetaLevTyUnit metaLevVal @@ -402,8 +415,9 @@ tyAsVarMp = tyAsVarMp' (flip const) -} -varmpLookup :: (VarLookup m k i,Ord k) => k -> m -> Maybe i -varmpLookup = varlookupMap (Just . id) +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 @@ -475,6 +489,7 @@ -- VarMp stack, for nested/local behavior +{- newtype VarMpStk' k v = VarMpStk [VarMp' k v] deriving (Show) @@ -507,6 +522,7 @@ instance Ord k => VarLookupCmb (VarMpStk' k v) (VarMpStk' k v) where (VarMpStk s1) |+> (VarMpStk s2) = VarMpStk (s1 |+> s2) +-} -- Pretty printing @@ -522,8 +538,10 @@ 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 diff --git a/uhc-util.cabal b/uhc-util.cabal --- a/uhc-util.cabal +++ b/uhc-util.cabal @@ -1,5 +1,5 @@ Name: uhc-util -Version: 0.1.6.5 +Version: 0.1.6.6 cabal-version: >= 1.6 License: BSD3 Copyright: Utrecht University, Department of Information and Computing Sciences, Software Technology group @@ -21,8 +21,9 @@ library Build-Depends: - base >= 4.8 && < 5, + base >= 4.8.1 && < 5, mtl >= 2, + transformers >= 0.4.2, fgl >= 5.4, hashable >= 1.2.4, containers >= 0.4, @@ -35,8 +36,8 @@ time-compat >= 0.1.0.1, time >= 1.2, fclabels >= 2.0.3, - syb >= 0.3.6, - logict-state >= 0.1.0.0 + logict-state >= 0.1.0.2, + pqueue >= 1.3.1 Exposed-Modules: UHC.Util.AGraph, UHC.Util.AssocL, @@ -46,8 +47,9 @@ UHC.Util.CHR.Base, UHC.Util.CHR.Rule, UHC.Util.CHR.Solve.TreeTrie.Mono, - UHC.Util.CHR.Solve.TreeTrie.Poly, UHC.Util.CHR.Solve.TreeTrie.MonoBacktrackPrio, + UHC.Util.CHR.Solve.TreeTrie.Examples.Term.Main, + UHC.Util.CHR.GTerm, UHC.Util.CompileRun, UHC.Util.CompileRun2, UHC.Util.CompileRun3, @@ -57,6 +59,7 @@ UHC.Util.Error, UHC.Util.FastSeq, UHC.Util.FPath, + UHC.Util.Fresh, UHC.Util.Hashable, UHC.Util.Lens, UHC.Util.Nm, @@ -71,16 +74,22 @@ UHC.Util.RLList.LexScope, UHC.Util.ScanUtils, UHC.Util.ScopeMapGam, + UHC.Util.ScopeVarMp, UHC.Util.Serialize, UHC.Util.Substitutable, UHC.Util.Time, UHC.Util.TreeTrie, + UHC.Util.TreeTrie2, UHC.Util.Utils, UHC.Util.VarLookup, UHC.Util.VarMp Other-Modules: - UHC.Util.CHR.Solve.TreeTrie.Internal + UHC.Util.CHR.Solve.TreeTrie.Internal.Shared, + UHC.Util.CHR.Solve.TreeTrie.Internal, + UHC.Util.CHR.GTerm.AST, + UHC.Util.CHR.GTerm.Parser, + UHC.Util.CHR.Solve.TreeTrie.Examples.Term.AST Ghc-Options: - HS-Source-Dirs: src + HS-Source-Dirs: src Build-Tools: - Extensions: NoMagicHash, DeriveGeneric, DeriveDataTypeable, TypeFamilies, FlexibleContexts + Extensions: NoMagicHash, DeriveGeneric, DeriveDataTypeable, TypeFamilies, FlexibleContexts, FunctionalDependencies, FlexibleInstances