chr-data (empty) → 0.1.0.0

raw patch · 21 files changed

+3491/−0 lines, 21 filesdep +arraydep +basedep +chr-prettysetup-changed

Dependencies added: array, base, chr-pretty, containers, fclabels, hashable, microlens, microlens-mtl, microlens-th, mtl, template-haskell, unordered-containers, vector

Files

• ChangeLog.md +5/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• chr-data.cabal +68/−0
• src/CHR/Data/AssocL.hs +81/−0
• src/CHR/Data/FastSeq.hs +162/−0
• src/CHR/Data/Fresh.hs +43/−0
• src/CHR/Data/Lens.hs +14/−0
• src/CHR/Data/Lens/FCLabels.hs +156/−0
• src/CHR/Data/Lens/MicroLens.hs +197/−0
• src/CHR/Data/Lookup.hs +54/−0
• src/CHR/Data/Lookup/Instances.hs +135/−0
• src/CHR/Data/Lookup/Scoped.hs +204/−0
• src/CHR/Data/Lookup/Stacked.hs +131/−0
• src/CHR/Data/Lookup/Types.hs +92/−0
• src/CHR/Data/Substitutable.hs +93/−0
• src/CHR/Data/TreeTrie.hs +426/−0
• src/CHR/Data/VarLookup.hs +249/−0
• src/CHR/Data/VarMp.hs +593/−0
• src/CHR/Data/VecAlloc.hs +103/−0
• src/CHR/Utils.hs +653/−0

@@ -0,0 +1,5 @@+# Revision history for chr-data++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,30 @@+Copyright (c) 2017, Atze Dijkstra++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Atze Dijkstra nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,68 @@+-- Initial chr-data.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                chr-data+version:             0.1.0.0+synopsis:            Datatypes required for chr library+description:         Datatypes required for chr library, in particular searching on treestructures, lookup abstraction, substitutions, etc. These are also used (via uhc-util) in UHC.+homepage:            https://github.com/atzedijkstra/chr+Bug-Reports:         https://github.com/atzedijkstra/chr/issues+license:             BSD3+license-file:        LICENSE+author:              Atze Dijkstra+maintainer:          atzedijkstra@gmail.com+-- copyright:           +category:            Development+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++source-repository head+  type:     git+  location: git@github.com:atzedijkstra/chr.git++library+  exposed-modules:     +    CHR.Utils,+    CHR.Data.Lens,+    CHR.Data.Lens.FCLabels,+    CHR.Data.Lens.MicroLens,+    CHR.Data.TreeTrie,+    CHR.Data.Lookup,+    CHR.Data.Lookup.Types,+    CHR.Data.Lookup.Instances,+    CHR.Data.Lookup.Scoped,+    CHR.Data.Lookup.Stacked+    CHR.Data.VarMp,+    CHR.Data.Substitutable,+    CHR.Data.VarLookup,+    CHR.Data.VecAlloc,+    CHR.Data.FastSeq,+    CHR.Data.AssocL,+    CHR.Data.Fresh+  other-modules:       +  default-extensions:+    NoMagicHash,+    DeriveGeneric,+    DeriveDataTypeable,+    TypeFamilies,+    FlexibleContexts,+    FunctionalDependencies,+    FlexibleInstances+  -- other-extensions:+  build-depends:+    base >=4.9 && < 5,+    array >= 0.3,+    containers >= 0.4,+    hashable >= 1.2.4,+    unordered-containers >= 0.2.7,+    mtl >= 2,+    fclabels >= 2.0.3,+    microlens >= 0.4,+    microlens-mtl >= 0.1.6.1,+    microlens-th >= 0.4,+    template-haskell >= 2.11,+    vector >= 0.11,+    chr-pretty >= 0.1.0.0+  hs-source-dirs:      src+  default-language:    Haskell2010

@@ -0,0 +1,81 @@+module CHR.Data.AssocL+    ( -- * Assoc list+      Assoc, AssocL+    , assocLMapElt, assocLMapKey+    , assocLElts, assocLKeys+    , assocLGroupSort+    , assocLMapUnzip+    , ppAssocL, ppAssocL'+    , ppAssocLV, ppAssocLH+    , ppCurlysAssocL+    +      -- * Utils+    , combineToDistinguishedElts+    )+  where+import CHR.Pretty+import CHR.Utils+import Data.List+import Data.Maybe+import Data.Function++-------------------------------------------------------------------------------------------+--- AssocL+-------------------------------------------------------------------------------------------++type Assoc k v = (k,v)+type AssocL k v = [Assoc k v]++ppAssocL' :: (PP k, PP v, PP s) => ([PP_Doc] -> PP_Doc) -> s -> AssocL k v -> PP_Doc+ppAssocL' ppL sep al = ppL (map (\(k,v) -> pp k >|< sep >#< pp v) al)++ppAssocL :: (PP k, PP v) => AssocL k v -> PP_Doc+ppAssocL = ppAssocL' (ppBlock "[" "]" ",") ":"++ppAssocLV :: (PP k, PP v) => AssocL k v -> PP_Doc+ppAssocLV = ppAssocL' vlist ":"+{-# INLINE ppAssocLV #-}++ppAssocLH :: (PP k, PP v) => AssocL k v -> PP_Doc+ppAssocLH = ppAssocL' (ppBlockH "[" "]" ", ") ":"+{-# INLINE ppAssocLH #-}++-- | intended for parsing+ppCurlysAssocL :: (k -> PP_Doc) -> (v -> PP_Doc) -> AssocL k v -> PP_Doc+ppCurlysAssocL pk pv = ppCurlysCommasBlock . map (\(k,v) -> pk k >#< "=" >#< pv v)++assocLMap :: (k -> v -> (k',v')) -> AssocL k v -> AssocL k' v'+assocLMap f = map (uncurry f)+{-# INLINE assocLMap #-}++assocLMapElt :: (v -> v') -> AssocL k v -> AssocL k v'+assocLMapElt f = assocLMap (\k v -> (k,f v))+{-# INLINE assocLMapElt #-}++assocLMapKey :: (k -> k') -> AssocL k v -> AssocL k' v+assocLMapKey f = assocLMap (\k v -> (f k,v))+{-# INLINE assocLMapKey #-}++assocLMapUnzip :: AssocL k (v1,v2) -> (AssocL k v1,AssocL k v2)+assocLMapUnzip l = unzip [ ((k,v1),(k,v2)) | (k,(v1,v2)) <- l ]++assocLKeys :: AssocL k v -> [k]+assocLKeys = map fst+{-# INLINE assocLKeys #-}++assocLElts :: AssocL k v -> [v]+assocLElts = map snd+{-# INLINE assocLElts #-}++assocLGroupSort :: Ord k => AssocL k v -> AssocL k [v]+assocLGroupSort = map (foldr (\(k,v) (_,vs) -> (k,v:vs)) (panic "CHR.Data.AssocL.assocLGroupSort" ,[])) . groupSortOn fst++-------------------------------------------------------------------------------------------+--- Utils: Combinations+-------------------------------------------------------------------------------------------++-- | Combine [[x1..xn],..,[y1..ym]] to [[x1..y1],[x2..y1],..,[xn..ym]].+--   Each element [xi..yi] is distinct based on the the key k in xi==(k,_)+combineToDistinguishedElts :: Eq k => [AssocL k v] -> [AssocL k v]+combineToDistinguishedElts = combineToDistinguishedEltsBy ((==) `on` fst)+{-# INLINE combineToDistinguishedElts #-}

@@ -0,0 +1,162 @@+module CHR.Data.FastSeq+  ( FastSeq((:++:),(::+:),(:+::))+  , Seq+  , isEmpty, null+  , empty+  , size+  , singleton+  , toList, fromList+  , map+  , union, unions+  , firstNotEmpty+  )+  where++import           Prelude hiding (null,map)+import           Data.Monoid+-- import qualified Data.ListLike as LL+import qualified Data.List as L+import qualified CHR.Utils as U++-------------------------------------------------------------------------+-- Fast sequence, i.e. delayed concat 'trick'+-------------------------------------------------------------------------++infixr 5 :++:, :+::+infixl 5 ::+:++data FastSeq a+  = !(FastSeq a) :++: !(FastSeq a)+  |          !a  :+:: !(FastSeq a)+  | !(FastSeq a) ::+:          !a+  | FSeq    !a+  | FSeqL   ![a]+  | FSeqNil++type Seq a = FastSeq a++empty :: FastSeq a+empty = FSeqNil++-------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------++instance Monoid (FastSeq a) where+  mempty  = empty+  mappend = union+  mconcat = unions++{-+instance LL.FoldableLL (FastSeq a) a where+  foldl op e seq = ++instance LL.ListLike (FastSeq a) a where+-}++-------------------------------------------------------------------------+-- Observations+-------------------------------------------------------------------------++isEmpty, null :: FastSeq a -> Bool+isEmpty FSeqNil      = True+isEmpty (FSeqL x   ) = L.null x+isEmpty (FSeq  _   ) = False+isEmpty (x1 :++: x2) = isEmpty x1 && isEmpty x2+isEmpty (x1 :+:: x2) = False+isEmpty (x1 ::+: x2) = False+-- isEmpty sq           = L.null $ toList sq++null = isEmpty++size :: FastSeq a -> Int+size FSeqNil      = 0+size (FSeqL x   ) = length x+size (FSeq  _   ) = 1+size (x1 :++: x2) = size x1 + size x2+size (x1 :+:: x2) = 1 + size x2+size (x1 ::+: x2) = size x1 + 1++-------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------++singleton :: a -> FastSeq a+singleton = FSeq++-------------------------------------------------------------------------+-- Deconstruction+-------------------------------------------------------------------------++-- | View as head and tail, if possible+viewMbCons :: FastSeq a -> Maybe (a, FastSeq a)+viewMbCons FSeqNil         = Nothing+viewMbCons (FSeq  x)       = Just (x, FSeqNil)+viewMbCons (FSeqL (h:t))   = Just (h, FSeqL t)+viewMbCons (FSeqL []   )   = Nothing+viewMbCons (h  :+:: t )    = Just (h, t)+viewMbCons (i  ::+: l )    = maybe (Just (l, FSeqNil)) (\(h,t) -> Just (h, t ::+: l)) $ viewMbCons i+viewMbCons (s1 :++: s2)    = maybe (viewMbCons s2) (\(h,t) -> Just (h, t :++: s2)) $ viewMbCons s1++{-+-- | View as init and last, if possible+viewMbSnoc :: FastSeq a -> Maybe (FastSeq a, a)+viewMbSnoc FSeqNil         = Nothing+viewMbSnoc (FSeqL (h:t))   = Just (h, FSeqL t)+viewMbSnoc (FSeqL []   )   = Nothing+viewMbSnoc (h  :+:: t )    = Just (h, t)+viewMbSnoc (i  ::+: l )    = maybe (Just (l, FSeqNil)) (\(h,t) -> Just (h, t ::+: l)) $ viewMbSnoc i+viewMbSnoc (s1 :++: s2)    = maybe (viewMbSnoc s2) (\(h,t) -> Just (h, t :++: s2)) $ viewMbSnoc s1+-}+++-------------------------------------------------------------------------+-- Conversion+-------------------------------------------------------------------------++fromList :: [a] -> FastSeq a+fromList [] = FSeqNil+fromList l  = FSeqL l++toList :: FastSeq a -> [a]+toList s+  = a s []+  where a FSeqNil      l = l+        a (FSeq  x   ) l = x : l+        a (FSeqL x   ) l = x L.++ l+        a (x1 :++: x2) l = a x1 (a x2 l)+        a (x1 :+:: x2) l = x1 : a x2 l+        a (x1 ::+: x2) l = a x1 (x2 : l)++-------------------------------------------------------------------------+-- Map, ...+-------------------------------------------------------------------------++map :: (a->b) -> FastSeq a -> FastSeq b+map f FSeqNil      = FSeqNil+map f (FSeq  x   ) = FSeq $ f x+map f (FSeqL x   ) = FSeqL $ L.map f x+map f (x1 :++: x2) = map f x1 :++: map f x2+map f (x1 :+:: x2) =     f x1 :+:: map f x2+map f (x1 ::+: x2) = map f x1 ::+:     f x2++-------------------------------------------------------------------------+-- Union+-------------------------------------------------------------------------++union :: FastSeq a -> FastSeq a -> FastSeq a+union FSeqNil FSeqNil = FSeqNil+union FSeqNil s2      = s2+union s1      FSeqNil = s1+union s1      s2      = s1 :++: s2++unions :: [FastSeq a] -> FastSeq a+unions [s] =                           s+unions  s  = L.foldr ( (:++:)) FSeqNil s++-------------------------------------------------------------------------+-- Misc+-------------------------------------------------------------------------++firstNotEmpty :: [FastSeq x] -> FastSeq x+firstNotEmpty = U.maybeHd empty id . filter (not . isEmpty)

@@ -0,0 +1,43 @@+-------------------------------------------------------------------------------------------+--- Freshness of something+-------------------------------------------------------------------------------------------++module CHR.Data.Fresh+  ( 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

@@ -0,0 +1,14 @@+{-| Minimal redefine + re-export of a lens package, restricting to the needs of the library(s) using it+-}++module CHR.Data.Lens+  ( -- dispatch on desired lens system+    -- module CHR.Data.Lens.FCLabels+    module CHR.Data.Lens.MicroLens++  )+  where++-- import CHR.Data.Lens.FCLabels+import CHR.Data.Lens.MicroLens+

@@ -0,0 +1,156 @@+{-| Minimal redefine + re-export of a lens package, fclabels+-}++{-# LANGUAGE TypeOperators, NoMonomorphismRestriction #-}++module CHR.Data.Lens.FCLabels+  ( (:->)+  , Lens++  -- * Access+  +  , (^*)++  , (^.)+  , (^=)+  , (^$=)+  , getL+  +  , (=.)+  , (=:)+  , (=$:)+  , modifyAndGet, (=$^:), modL+  , getl+  +  -- * Misc+  +  , focus+  +  , mkLabel+  +  -- * Tuple accessors+  , fstl+  , sndl+  , fst3l+  , snd3l+  , trd3l+  +  -- * Wrappers+  +  , isoMb+  , isoMbWithDefault++  )+  where++import           Prelude hiding ((.), id)+import qualified Control.Monad.State as MS+import           Control.Monad.Trans+import           Control.Category++import           Data.Label hiding (Lens, lens)+import qualified Data.Label.Base as L+import qualified Data.Label as L+import           Data.Label.Monadic((=:), (=.), modifyAndGet)+import qualified Data.Label.Monadic as M+import qualified Data.Label.Partial as P++import           CHR.Utils++-- * Textual alias for (:->), avoiding TypeOperators+type Lens a b = a :-> b++-- * Operator interface for composition++infixl 9 ^*+-- | composition with a flipped reading+(^*) :: (a :-> b) -> (b :-> c) -> (a :-> c)+f1 ^* f2 = f2 . f1+{-# INLINE (^*) #-}+++-- * Operator interface for functional part (occasionally similar to Data.Lens)++infixl 8 ^.+-- | functional getter, which acts like a field accessor+(^.) :: a -> (a :-> b) -> b+a ^. f = get f a+{-# INLINE (^.) #-}++-- | Alias for 'get' to avoid conflict with state get; not happy choice because of 'getl'+getL :: (f :-> a) -> f -> a+getL = get+{-# INLINE getL #-}++infixr 4 ^=+-- | functional setter, which acts like a field assigner+(^=) :: (a :-> b) -> b -> a -> a+(^=) = set+{-# INLINE (^=) #-}++infixr 4 ^$=+-- | functional modify+(^$=) :: (a :-> b) -> (b -> b) -> a -> a+(^$=) = modify+{-# INLINE (^$=) #-}++-- * Operator interface for monadic part (occasionally similar to Data.Lens)++infixr 4 =$^:+-- | monadic modify & set & get+(=$^:), modL :: MS.MonadState f m => (f :-> o) -> (o -> (a,o)) -> m a+(=$^:) = M.modifyAndGet+{-# INLINE (=$^:) #-}+modL = M.modifyAndGet+{-# INLINE modL #-}++infixr 4 =$:+-- | monadic modify & set+(=$:) :: MS.MonadState f m => (f :-> o) -> (o -> o) -> m ()+(=$:) = M.modify+{-# INLINE (=$:) #-}++-- | Zoom state in on substructure. This regretfully does not really work, because of MonadState fundep.+focus :: (MS.MonadState a m, MS.MonadState b m) => (a :-> b) -> m c -> m c+focus f m = do+  a <- MS.get+  (b,c) <- do {MS.put (get f a) ; c <- m ; b <- MS.get ; return (b,c)}+  MS.put $ set f b a+  return c+  +{-+ (Lens f) (StateT g) = StateT $ \a -> case f a of+  StoreT (Identity h) b -> liftM (second h) (g b)+-}++-- | Alias for 'gets' avoiding conflict with MonadState+getl :: MS.MonadState f m => (f :-> o) -> m o+getl = M.gets+{-# INLINE getl #-}++-- * Tuple++fstl = L.fst+{-# INLINE fstl #-}++sndl = L.snd+{-# INLINE sndl #-}++fst3l = L.fst3+{-# INLINE fst3l #-}++snd3l = L.snd3+{-# INLINE snd3l #-}++trd3l = L.trd3+{-# INLINE trd3l #-}++-- * Wrappers++-- | Wrapper around a Maybe with a default in case of Nothing+isoMbWithDefault :: o -> (f :-> Maybe o) -> (f :-> o)+isoMbWithDefault dflt f = iso (Iso (maybe dflt id) (Just)) . f++-- | Wrapper around a Maybe with an embedded panic in case of Nothing, with a panic message+isoMb :: String -> (f :-> Maybe o) -> (f :-> o)+isoMb msg f = iso (Iso (panicJust msg) (Just)) . f

@@ -0,0 +1,197 @@+{-| Minimal redefine + re-export of a lens package, fclabels+-}++{-# LANGUAGE TypeOperators, RankNTypes #-}++module CHR.Data.Lens.MicroLens+  ( +    (:->)+  , Lens+  -- , lens++  -- * Access+  +  , (^*)++  , (^.)+  , getL+  , (^=)+  , (^$=)+  +  {-+  +  , (=.)+  -}+  , (=:)+  , (=$:)+  , modifyAndGet+  , (=$^:)+  , modL+  , getl+  +  -- * Misc+  +  {-+  , focus+  -}+  +  , mkLabel+  +  -- * Tuple accessors+  , fstl+  , sndl+  , fst3l+  , snd3l+  , trd3l+  +  -- * Wrappers+  +  , isoMb+  , isoMbWithDefault++  )+  where++import qualified Control.Monad.State as MS+import           Lens.Micro                 hiding (Lens, lens)+import qualified Lens.Micro                 as L+import           Lens.Micro.Mtl+import           Lens.Micro.TH+import           Language.Haskell.TH++import           CHR.Utils++-- * Type aliases+type Lens a b = Lens' a b+type a :-> b = Lens' a b++lens :: (a -> b) -> (a -> b -> a) -> (a :-> b)+lens = L.lens+{-# INLINE lens #-}++-- * Operator interface for composition++infixl 9 ^*+-- | composition alias+(^*) :: (a :-> b) -> (b :-> c) -> (a :-> c)+f1 ^* f2 = f1 . f2+{-# INLINE (^*) #-}++{-++-- * Operator interface for functional part (occasionally similar to Data.Lens)++infixl 8 ^.+-- | functional getter, which acts like a field accessor+(^.) :: a -> (a :-> b) -> b+a ^. f = get f a+{-# INLINE (^.) #-}++-}++-- | Alias for 'get' to avoid conflict with state get; not happy choice because of 'getl'+getL :: (f :-> a) -> f -> a+getL = flip (^.)+{-# INLINE getL #-}++infixr 4 ^=+-- | functional setter, which acts like a field assigner+(^=) :: (a :-> b) -> b -> a -> a+(^=) = set+{-# INLINE (^=) #-}++infixr 4 ^$=+-- | functional modify+(^$=) :: (a :-> b) -> (b -> b) -> a -> a+(^$=) = over+{-# INLINE (^$=) #-}++{-+-}+-- * Operator interface for monadic part (occasionally similar to Data.Lens)++infixr 4 =$^:+-- | monadic modify & set & get+(=$^:), modL, modifyAndGet :: MS.MonadState f m => (f :-> o) -> (o -> (a,o)) -> m a+l =$^: f = do+    old <- use l+    let (res,new) = f old+    l =: new+    return res+{-# INLINE (=$^:) #-}+modL = (=$^:)+{-# INLINE modL #-}+modifyAndGet = (=$^:)+{-# INLINE modifyAndGet #-}++-- | monadic get+getl :: MS.MonadState f m => (f :-> o) -> m o+getl = use++infixr 4 =:+-- | monadic set+(=:) :: MS.MonadState f m => (f :-> o) -> o -> m ()+(=:) = (.=)+{-# INLINE (=:) #-}++infixr 4 =$:+-- | monadic modify & set+(=$:) :: MS.MonadState f m => (f :-> o) -> (o -> o) -> m ()+(=$:) = modifying+{-# INLINE (=$:) #-}++{-++-- | Zoom state in on substructure. This regretfully does not really work, because of MonadState fundep.+focus :: (MS.MonadState a m, MS.MonadState b m) => (a :-> b) -> m c -> m c+focus f m = do+  a <- MS.get+  (b,c) <- do {MS.put (get f a) ; c <- m ; b <- MS.get ; return (b,c)}+  MS.put $ set f b a+  return c++-- | Alias for 'gets' avoiding conflict with MonadState+getl :: MS.MonadState f m => (f :-> o) -> m o+getl = M.gets+{-# INLINE getl #-}++-}++-- * Misc++mkLabel :: Name -> Q [Dec]+mkLabel = makeLenses++-- * Tuple++fstl :: Lens (a,b) a+fstl = (_1)+{-# INLINE fstl #-}++sndl :: Lens (a,b) b+sndl = (_2)+{-# INLINE sndl #-}++fst3l :: Lens (a,b,c) a+fst3l = (_1)+{-# INLINE fst3l #-}++snd3l :: Lens (a,b,c) b+snd3l = (_2)+{-# INLINE snd3l #-}++trd3l :: Lens (a,b,c) c+trd3l = (_3)+{-# INLINE trd3l #-}++-- * Wrappers++-- | Wrapper around a Maybe with a default in case of Nothing+isoMbWithDefault :: o -> (f :-> Maybe o) -> (f :-> o)+-- isoMbWithDefault dflt f = iso (Iso (maybe dflt id) (Just)) . f+isoMbWithDefault dflt f = lens (\a -> maybe dflt id $ a ^. f) (\a b -> set f (Just b) a)++-- | Wrapper around a Maybe with an embedded panic in case of Nothing, with a panic message+isoMb :: String -> (f :-> Maybe o) -> (f :-> o)+-- isoMb msg f = iso (Iso (panicJust msg) (Just)) . f+isoMb msg f = lens (\a -> panicJust msg $ a ^. f) (\a b -> set f (Just b) a)

@@ -0,0 +1,54 @@+-------------------------------------------------------------------------------------------+-- Abstraction of Map like datatypes providing lookup+-------------------------------------------------------------------------------------------++module CHR.Data.Lookup+  (+    module CHR.Data.Lookup.Types+  , module CHR.Data.Lookup.Instances+  , module CHR.Data.Lookup.Scoped+  , module CHR.Data.Lookup.Stacked+  +  , lookupResolveVar+  , lookupResolveVal+  , lookupResolveAndContinueM+  +  , inverse+  )+  where++-------------------------------------------------------------------------------------------+import           Prelude                        hiding (lookup, map)+import qualified Data.List                      as List+import           Control.Applicative+import           CHR.Data.Lookup.Types+import           CHR.Data.Lookup.Instances+import           CHR.Data.Lookup.Scoped         (Scoped)+import           CHR.Data.Lookup.Stacked        (Stacked)+import           CHR.Data.VarLookup             (VarLookupKey, VarLookupVal)+-------------------------------------------------------------------------------------------++-------------------------------------------------------------------------------------------+--- Lookup and resolution+-------------------------------------------------------------------------------------------++-- | Fully resolve lookup+lookupResolveVar :: Lookup m (VarLookupKey m) (VarLookupVal m) => (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupKey m -> m -> Maybe (VarLookupVal m)+lookupResolveVar isVar k m = lookup k m >>= \v -> lookupResolveVal isVar v m <|> return v++-- | Fully resolve lookup+lookupResolveVal :: Lookup m (VarLookupKey m) (VarLookupVal m) => (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupVal m -> m -> Maybe (VarLookupVal m)+lookupResolveVal isVar v m = isVar v >>= \k -> lookupResolveVar isVar k m <|> return v++-- | Monadically lookup a variable, resolve it, continue with either a fail or success monad continuation+lookupResolveAndContinueM :: (Monad m, Lookup s (VarLookupKey s) (VarLookupVal s)) => (VarLookupVal s -> Maybe (VarLookupKey s)) -> (m s) -> (m a) -> (VarLookupVal s -> m a) -> VarLookupKey s -> m a+lookupResolveAndContinueM tmIsVar gets failFind okFind k = gets >>= \s -> maybe failFind okFind $ lookupResolveVar tmIsVar k s++-------------------------------------------------------------------------------------------+--- Utils+-------------------------------------------------------------------------------------------++-- | Inverse of a lookup+inverse :: (Lookup l1 k1 v1, Lookup l2 k2 v2) => (k1 -> v1 -> (k2,v2)) -> l1 -> l2+inverse mk = fromList . List.map (uncurry mk) . toList+

@@ -0,0 +1,135 @@+{-# LANGUAGE UndecidableInstances #-}++-------------------------------------------------------------------------------------------+-- Abstraction of Map like datatypes providing lookup+-------------------------------------------------------------------------------------------++module CHR.Data.Lookup.Instances+  (+  +  )+  where++-------------------------------------------------------------------------------------------+import qualified Data.IntMap                as IMap+import qualified Data.Map                   as Map+import qualified Data.HashMap.Strict        as MapH+import qualified Data.Set                   as Set+import qualified CHR.Data.VecAlloc          as VAr+import           Data.Hashable+import           Data.Array.IArray          as IAr+import           CHR.Data.Lookup.Types+-------------------------------------------------------------------------------------------++-------------------------------------------------------------------------------------------+-- Instances: Lookup+-------------------------------------------------------------------------------------------++instance Ord k => Lookup (Map.Map k v) k v where+  lookup            = Map.lookup+  {-+  findMin           = Map.findMin+  findMax           = Map.findMax+  -}+  fromList          = Map.fromList+  toList            = Map.toList+  null              = Map.null+  size              = Map.size+  alter             = Map.alter+  +  -- optional+  unionWith         = Map.unionWith+  insertWith        = Map.insertWith+  delete            = Map.delete+  singleton         = Map.singleton+  empty             = Map.empty+  keys              = Map.keys+  keysSet           = Map.keysSet+  elems             = Map.elems+  map               = Map.map++instance (Eq k, Hashable k) => Lookup (MapH.HashMap k v) k v where+  lookup            = MapH.lookup+  {-+  findMin           = Map.findMin+  findMax           = Map.findMax+  -}+  fromList          = MapH.fromList+  toList            = MapH.toList+  null              = MapH.null+  size              = MapH.size+  alter             = MapH.alter+  +  -- optional+  unionWith         = MapH.unionWith+  insertWith        = MapH.insertWith+  delete            = MapH.delete+  singleton         = MapH.singleton+  empty             = MapH.empty+  keys              = MapH.keys+  -- keysSet           = MapH.keysSet+  elems             = MapH.elems+  map               = MapH.map++instance Lookup (IMap.IntMap v) IMap.Key v where+  lookup            = IMap.lookup+  {-+  findMin           = IMap.findMin+  findMax           = IMap.findMax+  -}+  fromList          = IMap.fromList+  toList            = IMap.toList+  null              = IMap.null+  size              = IMap.size+  alter             = IMap.alter++  -- optional+  unionWith         = IMap.unionWith+  insertWith        = IMap.insertWith+  delete            = IMap.delete+  singleton         = IMap.singleton+  empty             = IMap.empty+  keys              = IMap.keys+  elems             = IMap.elems+  map               = IMap.map+  -- keysSet            = IMap.keysSet++{-+-- | A rather costly inefficient implementation...+instance (Ix i, IArray a e) => Lookup (a i e) i e where+  lookup i a        = if inRange (bounds a) i then Just (a ! i) else Nothing+  {-+  findMin a         = (l, a ! l)+                    where (l,_) = bounds a+  findMax a         = (u, a ! u)+                    where (_,u) = bounds a+  -}+  insertWith f k v c= unionWith f (singleton k v) c+  unionWith f a1 a2 = accum f (array (min l1 l2, max u1 u2) (toList a1)) (toList a2)+                    where (l1,u1) = bounds a1+                          (l2,u2) = bounds a2+  fromList l        = array (minimum ixs, maximum ixs) l+                    where ixs = map fst l+  toList            = assocs+  null  a           = h < l+                    where (l,h) = bounds a+  alter             = alterDefault+  delete            = error "instance Lookup for IArray: no impl for delete"+-}++instance Lookup (VAr.VecAlloc e) Int e where+  lookup            = VAr.lookup+  alter             = VAr.alter+  toList            = VAr.toList+  fromList          = VAr.fromList+  null              = VAr.null++-------------------------------------------------------------------------------------------+-- Instances: LookupApply+-------------------------------------------------------------------------------------------++{-+instance {-# OVERLAPPABLE #-} Lookup l k v => LookupApply l l where+  apply = union+-}+  

@@ -0,0 +1,204 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}++-------------------------------------------------------------------------------------------+-- | Scoped Lookup allowing items to have a scope associated. A scope identifies a position in a tree representing nesting.+-- The Lookup has its own scope, i.e. maintains contextual state about 'where it is' in terms of nesting, thus allowing to query whether an item can see the current scope.+-------------------------------------------------------------------------------------------++module CHR.Data.Lookup.Scoped+  ( Scoped(..)+  +  , DefaultScpsLkup+  , defaultScpsLkup+  )+  where++-------------------------------------------------------------------------------------------+import           Control.Arrow+import           Control.Monad.State+import           CHR.Data.Lookup.Types       hiding (empty)+import qualified CHR.Data.Lookup.Types       as Lkup+import           CHR.Pretty             hiding (empty)+import           CHR.Data.Lens               as L+import           Prelude                     hiding (lookup, null, map)+import qualified Data.List                   as List+import qualified Data.Map                    as Map+import qualified Data.Vector.Unboxed         as UV+import qualified Data.Vector.Unboxed.Mutable as MV+-------------------------------------------------------------------------------------------++-------------------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------------------++-- | Scope id+type ScpId = Int++-- | Scopes+data Scopes+  = Scopes+      { _scopesVec     :: UV.Vector ScpId+      , _scopesFree    :: ScpId+      , _scopesCur     :: ScpId+      }++instance Show Scopes where+  show (Scopes v _ _) = show v++instance PP Scopes where+  pp = pp . show++-- | Scoped item+data ScopedItem v+  = ScopedItem+      { _scopeditemId  :: ScpId+      , _scopeditemVal :: v+      }+  deriving Show++instance PP v => PP (ScopedItem v) where+  pp (ScopedItem i v) = v >|< ppParens i++-- | Default scope lookup+data ScpsLkup lkup scps+  = ScpsLkup+      { _scpslkupBase    :: lkup+      , _scpslkupScopes  :: scps+      }+  deriving Show++instance (PP lkup, PP scps) => PP (ScpsLkup lkup scps) where+  pp (ScpsLkup lkup scps) = lkup >-< scps++-------------------------------------------------------------------------------------------+-- Lenses+-------------------------------------------------------------------------------------------++mkLabel ''ScopedItem+mkLabel ''Scopes+mkLabel ''ScpsLkup++-------------------------------------------------------------------------------------------+-- Scopes utils+-------------------------------------------------------------------------------------------++-- | Ensure enough free slots+scpEnsure :: Int -> Scopes -> Scopes+scpEnsure free s@(Scopes {_scopesVec=v, _scopesFree=f})+  | free >= f - UV.length v = s+  | otherwise               = s {_scopesVec = v UV.++ UV.replicate (free `max` ((3 * UV.length v) `div` 2)) 0}+{-# INLINE scpEnsure #-}++-- | Allocate new entry, init to point back to current, switch to it; assume enough free size.+-- Modification is done destructively but only on newly allocated position+scpAlloc :: Scopes -> (ScpId, Scopes)+scpAlloc s@(Scopes {_scopesVec=v, _scopesFree=f, _scopesCur=c}) = (f, s {_scopesFree = f+1, _scopesVec = UV.modify (\v -> MV.write v f c) v, _scopesCur = f})+{-# INLINE scpAlloc #-}++-------------------------------------------------------------------------------------------+-- Scope API+-------------------------------------------------------------------------------------------++-- | Functionality on top of 'Lookup' for awareness of a scope+class Scoped c where+  empty         :: c+  new           :: c -> (ScpId,c)+  pop           :: c -> (ScpId,c)+  switch        :: ScpId -> c -> (ScpId,c)+  scope         :: c -> ScpId+  -- | Something at current scope is visible from given scope, i.e. given scope is inside current scope+  curIsVisibleFrom  :: ScpId -> c -> Bool+  +  -- monadic api+  newM          :: (MonadState c m) => m ScpId+  popM          :: (MonadState c m) => m ScpId+  switchM       :: (MonadState c m) => ScpId -> m ScpId+  scopeM        :: (MonadState c m) => m ScpId+  curIsVisibleFromM :: (MonadState c m) => ScpId -> m Bool+  +  -- defaults both ways+  newM = state new+  new  = runState newM+  +  popM = state pop+  pop  = runState popM++  switchM = state . switch+  switch  = runState . switchM+  +  scopeM = gets scope+  scope  = evalState scopeM+  +  curIsVisibleFromM = gets . curIsVisibleFrom+  curIsVisibleFrom  = evalState . curIsVisibleFromM++instance Scoped Scopes where+  empty  = Scopes (UV.replicate 3 0) 1 0+  new    = scpAlloc . scpEnsure 1+  switch i s = (_scopesCur s, s {_scopesCur = i})+  scope  = _scopesCur+  pop s@(Scopes {_scopesVec=v, _scopesCur=c})+         = (c, s {_scopesCur = v UV.! c})+  curIsVisibleFrom i s@(Scopes {_scopesVec=v, _scopesCur=c})+    | i == c    = True+    | i == 0    = False+    | otherwise = curIsVisibleFrom (v UV.! i) s++-------------------------------------------------------------------------------------------+-- Default impl+-------------------------------------------------------------------------------------------++type DefaultScpsLkup k v = ScpsLkup (Map.Map k (ScopedItem v)) Scopes++defaultScpsLkup :: DefaultScpsLkup k v+defaultScpsLkup = ScpsLkup Map.empty empty++whenInScps :: Scoped c => c -> ScpId -> v -> Maybe v+whenInScps scps sc v = if curIsVisibleFrom sc scps then return v else Nothing++instance (Scoped scps, Lookup lkup k v) => Scoped (ScpsLkup lkup scps) where+  empty        = ScpsLkup Lkup.empty empty+  newM         = modL scpslkupScopes new+  popM         = modL scpslkupScopes pop+  switchM      = modL scpslkupScopes . switch+  scope        = scope . getL scpslkupScopes+  curIsVisibleFrom i = curIsVisibleFrom i . getL scpslkupScopes++instance (Scoped scps, Lookup lkup k (ScopedItem v)) => Lookup (ScpsLkup lkup scps) k v where+  lookup k (ScpsLkup lkup scps) = do+    ScopedItem sc v <- lookup k lkup+    whenInScps scps sc v++  alter f k (ScpsLkup lkup scps) =+    ScpsLkup (alter (maybe ((ScopedItem $ scope scps) <$> f Nothing)+                           (\(ScopedItem sc v) -> ScopedItem sc <$> f (Just v))+                    )+                    k lkup+             )+             scps+            +  -- first a quick test, then the more expensive+  null l@(ScpsLkup lkup scps) = null lkup || List.null (toList l)+  +  size l@(ScpsLkup lkup _) = size lkup+  +  {-+  -- should restrict to items which are nested inside current scope+  findMin (ScpsLkup lkup scps) = second _scopeditemVal $ findMin lkup+  findMax (ScpsLkup lkup scps) = second _scopeditemVal $ findMax lkup+  -}+  +  toList (ScpsLkup lkup scps) = [ (k,v) | (k, ScopedItem sc v) <- toList lkup, curIsVisibleFrom sc scps ]+  fromList l = (ScpsLkup (fromList $ List.map (\(k,v) -> (k, ScopedItem (scope s) v)) l) s)+    where s = empty++  {-+  -- for performance reasons, should cater for nesting...+  keysSet = keysSet . getL scpslkupBase+  keys    = keys    . getL scpslkupBase+  -}

@@ -0,0 +1,131 @@+{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}++-------------------------------------------------------------------------------------------+-- | Lookups combined into stack of lookups, allowing combined lookup coupled with updates on top of stack only+-------------------------------------------------------------------------------------------++module CHR.Data.Lookup.Stacked+  ( Stacked(..)+  , StackedElt+  +  , Stacks(..)+  )+  where++-------------------------------------------------------------------------------------------+import           Control.Applicative+import           Control.Arrow+import           Control.Monad.State+import           CHR.Data.Lookup.Types+import           CHR.Pretty+import           CHR.Data.Lens               as L+import           Prelude                     hiding (lookup, null, map)+import           Data.Maybe+import qualified Data.List                   as List+import qualified Data.Map                    as Map+import qualified Data.Set                    as Set+import qualified Data.Vector.Unboxed         as UV+import qualified Data.Vector.Unboxed.Mutable as MV+-------------------------------------------------------------------------------------------++-------------------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------------------++-- | Stacked Lookup derived from a base one, to allow a use of multiple lookups but update on top only+newtype Stacks l = Stacks {unStacks :: [l]}+  deriving (Functor, Applicative)++-------------------------------------------------------------------------------------------+-- Lenses+-------------------------------------------------------------------------------------------++-------------------------------------------------------------------------------------------+-- Stacked API+-------------------------------------------------------------------------------------------++type family StackedElt stk :: *++-- | Functionality on top of 'Lookup' for awareness of a scope.+-- Minimal definition 'lifts', 'unlifts,', 'top'/'topM', 'pop'/'popM', 'push'/'pushM'+class Stacked stk where+  -- lifting in/out+  lifts         :: StackedElt stk -> stk+  unlifts       :: stk -> [StackedElt stk]+  +  -- basic api+  top           :: stk -> StackedElt stk+  pop           :: stk -> (StackedElt stk,stk)+  push          :: StackedElt stk -> stk -> stk+  +  -- monadic api+  topM          :: (MonadState stk m) => m (StackedElt stk)+  popM          :: (MonadState stk m) => m (StackedElt stk)+  pushM         :: (MonadState stk m) => StackedElt stk -> m ()+  +  -- lifted variations+  tops          :: stk -> stk+  pops          :: stk -> (stk,stk)+  pushs         :: stk -> stk -> stk        -- ^ push, but only top of first arg++  -- lifted monadic variations+  topsM         :: (MonadState stk m) => m stk+  popsM         :: (MonadState stk m) => m stk+  pushsM        :: (MonadState stk m) => stk -> m ()++  -- defaults one way+  tops      = lifts . top+  pops      = first lifts . pop+  pushs     = push . top+  topsM     = gets tops+  popsM     = state pops+  pushsM    = modify . pushs+  +  -- defaults both ways+  topM = gets top+  top  = evalState topM+  +  popM = state pop+  pop  = runState popM++  pushM = modify . push+  push  = execState . pushM++-------------------------------------------------------------------------------------------+-- Default impl+-------------------------------------------------------------------------------------------++type instance StackedElt (Stacks e) = e++instance Stacked (Stacks lkup) where+  lifts e = Stacks [e]+  unlifts = unStacks+  top = List.head . unStacks+  pop (Stacks (h:t)) = (h, Stacks t)+  push h (Stacks t) = Stacks (h:t)++instance (Lookup lkup k v) => Lookup (Stacks lkup) k v where+  lookup  k  = listToMaybe . catMaybes . List.map (lookup k) . unStacks+  alter f k  = Stacks . List.map (alter f k) . unStacks+  null       = all null . unStacks+  size       = sum . List.map size . unStacks+  toList     = concatMap toList . unStacks+  fromList   = lifts . fromList++  -- for performance reasons+  keysSet = Set.unions . List.map keysSet . unStacks++-- modifications only for top level, otherwise use <$>+instance LookupApply l1 l2 => LookupApply l1 (Stacks l2) where+  l1 `apply` Stacks (h:t) = Stacks $ apply l1 h : t++instance Show (Stacks s) where+  show _ = "Stacks"++instance PP s => PP (Stacks s) where+  pp (Stacks xs) = ppCurlysCommas $ List.map pp xs+

@@ -0,0 +1,92 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-------------------------------------------------------------------------------------------+-- Abstraction of Map like datatypes providing lookup+-------------------------------------------------------------------------------------------++module CHR.Data.Lookup.Types+  (+    Lookup(..)+  , LookupApply(..)++  , alterDefault+  +  )+  where++-------------------------------------------------------------------------------------------+import qualified Data.Set as Set+import           Control.Arrow+import           Prelude                     hiding (lookup, map)+import qualified Data.List                   as List+-------------------------------------------------------------------------------------------++-------------------------------------------------------------------------------------------+-- Lookup+-------------------------------------------------------------------------------------------++-- | Class interface uses same names as Data.Map.+-- Instances must define: 'lookup', 'findMin', 'findMax', 'fromList', 'toList', 'null', 'alter'.+-- Union is left-biased in that left operand values overwrite right operand values, but all other context/info (if any and/or relevant, like scope) is inherited from the right one.+class Lookup c k v | c -> k, c -> v where+  -- core functionality+  -- extraction+  lookup        :: k -> c -> Maybe v+  {-+  findMin       :: c -> (k, v)+  findMax       :: c -> (k, v)+  -}+  -- (de)construction+  fromList      :: [(k,v)] -> c+  toList        :: c -> [(k,v)]+  -- properties+  null          :: c -> Bool+  size          :: c -> Int+  -- update catchall+  alter         :: (Maybe v -> Maybe v) -> k -> c -> c+ +  -- derived functionality, included as to allow optimization+  singleton     :: k -> v -> c+  empty         :: c+  insertWith    :: (v -> v -> v) -> k -> v -> c -> c+  insert        :: k -> v -> c -> c+  unionWith     :: (v -> v -> v) -> c -> c -> c+  union         :: c -> c -> c+  unionsWith    :: (v -> v -> v) -> [c] -> c+  unions        :: [c] -> c+  delete        :: k -> c -> c+  keys          :: c -> [k]+  keysSet       :: Ord k => c -> Set.Set k+  elems         :: c -> [v]+  map           :: (v -> v) -> c -> c++  -- defs for functions of which def is optional +  singleton k v         = fromList [(k,v)]+  empty                 = fromList []+  insertWith f k v c    = alter (Just . maybe v (f v)) k c+  insert                = insertWith const+  unionWith f c1 c2     = foldr (uncurry $ insertWith f) c2 $ toList c1+  union                 = unionWith const+  unionsWith f []       = empty+  unionsWith f l        = foldr1 (unionWith f) l+  unions                = unionsWith const+  delete                = alter (const Nothing)+  keys                  = List.map fst . toList+  keysSet               = Set.fromList . keys+  elems                 = List.map snd . toList+  map f                 = fromList . List.map (second f) . toList+  null c                = size c == 0++-- | Default for 'alter' when 'lookup', 'insert' (or 'inserWith'), and 'delete' are defined+alterDefault :: Lookup c k v => (Maybe v -> Maybe v) -> k -> c -> c+alterDefault f k c = case f $ lookup k c of+    Just v -> insert k v c+    _      -> delete k c++-------------------------------------------------------------------------------------------+-- Lookup application, fixing the combination+-------------------------------------------------------------------------------------------++class LookupApply l1 l2 where+  apply :: l1 -> l2 -> l2

@@ -0,0 +1,93 @@+-------------------------------------------------------------------------------------------+--- Substitution abilities+-------------------------------------------------------------------------------------------++{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}++module CHR.Data.Substitutable+  (+    VarUpdatable(..)+  , VarExtractable(..)+  +  , ExtrValVarKey+  +  , VarTerm(..)+  )+  where++import qualified Data.Set as Set+import           CHR.Data.VarMp++-------------------------------------------------------------------------------------------+--- Misc+-------------------------------------------------------------------------------------------++infixr 6 `varUpd`+infixr 6 `varUpdCyc`++-- | The variable wich is used as a key into a substitution+type family ExtrValVarKey vv :: *++-------------------------------------------------------------------------------------------+--- Updatable+-------------------------------------------------------------------------------------------++-- | Term in which variables can be updated with a subst(itution)+class VarUpdatable vv subst where+  -- | Update+  varUpd            ::  subst -> vv -> vv+  -- s `varUpd` x = let (x',_) = s `varUpdCyc` x in x+  -- {-# INLINE varUpd #-}++  -- | Update with cycle detection+  varUpdCyc         ::  subst -> vv -> (vv, VarMp' (VarLookupKey subst) (VarLookupVal subst))+  s `varUpdCyc` x = (s `varUpd` x, emptyVarMp)+  {-# INLINE varUpdCyc #-}++instance {-# OVERLAPPABLE #-} VarUpdatable vv subst => VarUpdatable (Maybe vv) subst where+  s `varUpd`    m = fmap (s `varUpd`) m++  s `varUpdCyc` (Just x) = let (x',cm) = s `varUpdCyc` x in (Just x', cm)+  s `varUpdCyc` Nothing  = (Nothing, emptyVarMp)++instance {-# OVERLAPPABLE #-} (Ord (VarLookupKey subst), VarUpdatable vv subst) => VarUpdatable [vv] subst where+  s `varUpd`    l = map (s `varUpd`) l+  s `varUpdCyc` l = let (l',cms) = unzip $ map (s `varUpdCyc`) l in (l', varmpUnions cms)++-------------------------------------------------------------------------------------------+--- Extractibility of free vars+-------------------------------------------------------------------------------------------++-- | Term from which free variables can be extracted+class Ord (ExtrValVarKey vv) => VarExtractable vv where+  -- | Free vars, as a list+  varFree           ::  vv -> [ExtrValVarKey vv]+  varFree           =   Set.toList . varFreeSet+  +  -- | Free vars, as a set+  varFreeSet        ::  vv -> Set.Set (ExtrValVarKey vv)+  varFreeSet        =   Set.fromList . varFree++type instance ExtrValVarKey (Maybe vv) = ExtrValVarKey vv++instance {-# OVERLAPPABLE #-} (VarExtractable vv, Ord (ExtrValVarKey vv)) => VarExtractable (Maybe vv) where+  varFreeSet        =   maybe Set.empty varFreeSet++type instance ExtrValVarKey [vv] = ExtrValVarKey vv++instance {-# OVERLAPPABLE #-} (VarExtractable vv, Ord (ExtrValVarKey vv)) => VarExtractable [vv] where+  varFreeSet        =   Set.unions . map varFreeSet++-------------------------------------------------------------------------------------------+--- Is a term with a variable which we can observe and construct+-------------------------------------------------------------------------------------------++-- | Term with a (substitutable, extractable, free, etc.) variable+class VarTerm vv where+  -- | Maybe is a key+  varTermMbKey :: vv -> Maybe (ExtrValVarKey vv)+  -- | Construct wrapper for key (i.e. lift, embed)+  varTermMkKey :: ExtrValVarKey vv -> vv+  ++

@@ -0,0 +1,426 @@+{-# LANGUAGE CPP, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, MultiParamTypeClasses, PatternGuards, GADTs, ConstraintKinds #-}++-------------------------------------------------------------------------------------------+--- 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 CHR.Data.TreeTrie+  ( -- * Key into TreeTrie+    PreKey1+  , Key+  +    -- * Keyable+  , TrTrKey+  , TreeTrieKeyable(..)+  , toTreeTrieKey+  +  , prekey1+  , prekey1Wild+  , prekey1Nil+  , prekey1Delegate+  , prekey1WithChildren+  , prekey1With2Children+  , prekey1WithChild+  +    -- * TreeTrie+  , TreeTrie+  , TTCtxt+  , emptyTreeTrie+  , empty+  , toListByKey, toList+  , fromListByKeyWith, fromList+  +    -- * Lookup+  , lookup+  , lookupResultToList+    -- * Properties/observations+  , isEmpty, null+  +    -- * Construction+  , singleton, singletonKeyable+  , unionWith, union, unionsWith, unions+  , insertByKeyWith, insertByKey+  +  )+  where++import           Prelude                    hiding (lookup,null)++import qualified Data.Set                   as Set+import qualified Data.Map                   as Map+import           Data.Maybe+import           Data.Monoid+import qualified Data.List                  as List+import           Data.Typeable(Typeable)++import           GHC.Generics++import           Control.Monad++import           CHR.Utils+import qualified CHR.Data.Lookup            as Lk++-- import           UHC.Util.Serialize+import           CHR.Pretty                 hiding (empty)+import qualified CHR.Pretty                 as PP+-- import           CHR.Data.AssocL+import qualified CHR.Data.FastSeq           as Seq++-------------------------------------------------------------------------------------------+--- Key AST, used to index into TreeTrie+-------------------------------------------------------------------------------------------++-- | Key used on 1 level of trie.+-- Key1_Wild plays a special role, may occur in Key1_Multi only, and in there it is guaranteed to have non wild siblings, allowing easy wildcard lookup where only not all elements of the group need be a specific Key1_Single+data Key1 k+  = Key1_Single !k+  | Key1_Multi  ![Key1 k]+  | Key1_Wild                   -- ^ equal to anything+  | Key1_Nil                    -- ^ equal to nothing, except Key1_Wild+  deriving (Generic, Typeable {-, Eq, Ord -})++instance Functor Key1 where+  fmap f (Key1_Single k) = Key1_Single $ f k+  fmap f (Key1_Multi ks) = Key1_Multi  $ map (fmap f) ks+  fmap _ Key1_Wild       = Key1_Wild+  fmap _ Key1_Nil        = Key1_Nil++{-+-}+instance Eq k => Eq (Key1 k) where+  Key1_Single k1 == Key1_Single k2 = k1  == k2+  Key1_Multi ks1 == Key1_Multi ks2 = ks1 == ks2+  Key1_Nil       == Key1_Nil       = True+  Key1_Wild      == _              = True+  _              == Key1_Wild      = True+  _              == _              = False++instance Ord k => Ord (Key1 k) where+  Key1_Single k1 `compare` Key1_Single k2 = k1  `compare` k2+  Key1_Multi ks1 `compare` Key1_Multi ks2 = ks1 `compare` ks2+  Key1_Nil       `compare` Key1_Nil       = EQ+  Key1_Wild      `compare` _              = EQ+  _              `compare` Key1_Wild      = EQ+  Key1_Nil       `compare` _              = LT+  _              `compare` Key1_Nil       = GT+  Key1_Single _  `compare` _              = LT+  _              `compare` Key1_Single _  = GT++instance Show k => Show (Key1 k) where+  show (Key1_Single k) = "(" ++ show k ++ ")"+  show (Key1_Multi ks) = "[" ++ (concat $ List.intersperse "," $ map show ks) ++ "]"+  show  Key1_Wild      = "*"+  show  Key1_Nil       = "_"++instance PP k => PP (Key1 k) where+  pp (Key1_Single k) = ppParens k+  pp (Key1_Multi ks) = ppBracketsCommas ks+  pp  Key1_Wild      = pp "*"+  pp  Key1_Nil       = pp "_"++key1IsWild :: Key1 k -> Bool+key1IsWild Key1_Wild = True+key1IsWild _         = False+{-# INLINE key1IsWild #-}++-- | Full key+newtype Key k = Key {unKey :: [Key1 k]}+  deriving (Eq, Ord, Generic, Typeable, Show)++instance PP k => PP (Key k) where+  pp = ppBracketsCommas . unKey++-- | Simplify a generated raw Key1 into its canonical form used for indexing+key1RawToCanon :: Key1 k -> Key1 k+key1RawToCanon k = case k of+    Key1_Multi ks +      | List.null ks  -> Key1_Nil+      | all iswld sks -> Key1_Wild+      | all issim sks -> Key1_Nil+      | [sk] <- sks   -> sk+      | otherwise     -> Key1_Multi sks+      where sks = map key1RawToCanon ks+    -- k | issimp k       -> Key1_Nil+    k                  -> k+  where -- issimp Key1_Wild = True+        isnil Key1_Nil  = True+        isnil _         = False+        iswld Key1_Wild = True+        iswld _         = False+        issim k         = isnil k || iswld k++-- | Simplify a generated raw Key into its canonical form used for indexing+keyRawToCanon :: Key k -> Key k+keyRawToCanon = Key . simp . unKey+  where simp ks = case ks of+          (k:ks) | Key1_Nil  <- kc -> []+                 | Key1_Wild <- kc -> [] -- [Key1_Wild] -- if only wild further subtree matching would succeed by def+                 | otherwise       -> kc : simp ks+            where kc = key1RawToCanon k+          _ -> []++-------------------------------------------------------------------------------------------+--- Keyable+-------------------------------------------------------------------------------------------++type family TrTrKey x :: *++type instance TrTrKey [x] = TrTrKey x+type instance TrTrKey (Maybe x) = TrTrKey x++data PreKey1Cont y where+  PreKey1Cont_None :: PreKey1Cont y+  PreKey1Cont      :: (TrTrKey y ~ TrTrKey x, TreeTrieKeyable x) =>  x  -> PreKey1Cont y+  PreKey1Cont2     :: (TrTrKey y ~ TrTrKey x1, TrTrKey y ~ TrTrKey x2, TreeTrieKeyable x1, TreeTrieKeyable x2) =>  x1 -> x2  -> PreKey1Cont y+  PreKey1Conts     :: (TrTrKey y ~ TrTrKey x, TreeTrieKeyable x) => [x] -> PreKey1Cont y++data PreKey1 x+  = PreKey1       (TrTrKey x) (PreKey1Cont x)+  | PreKey1_Deleg             (PreKey1Cont x)+  | PreKey1_Wild+  | PreKey1_Nil+  +-- | Keyable values, i.e. capable of yielding a TreeTrieKey for retrieval from a trie+class TreeTrieKeyable x where+  toTreeTriePreKey1 :: x -> PreKey1 x++toTreeTrieKey :: TreeTrieKeyable x => x -> Key (TrTrKey x)+toTreeTrieKey = keyRawToCanon . Key . mkx+  where nil   = repeat Key1_Nil+        mkx x = case toTreeTriePreKey1 x of+                  PreKey1 k     mbx -> Key1_Single k : cont mbx+                  PreKey1_Deleg mbx -> cont mbx+                  PreKey1_Wild      -> repeat Key1_Wild+                  PreKey1_Nil       -> nil+        cont :: PreKey1Cont y -> [Key1 (TrTrKey y)]+        cont c = case c of+          PreKey1Cont_None -> nil+          PreKey1Cont  x   -> mkx x+          PreKey1Cont2 x y -> zipWithN Key1_Multi [mkx x, mkx y]+          PreKey1Conts xs  -> zipWithN Key1_Multi $ map mkx xs++-- | Single key+prekey1 :: TrTrKey x -> PreKey1 x+prekey1 k = PreKey1 k PreKey1Cont_None++-- | Wildcard, matching anything+prekey1Wild :: PreKey1 x+prekey1Wild = PreKey1_Wild++-- | No key+prekey1Nil :: PreKey1 x+prekey1Nil = PreKey1_Nil++-- | No key, delegate to next layer+prekey1Delegate :: (TrTrKey y ~ TrTrKey x, TreeTrieKeyable y) => y -> PreKey1 x+prekey1Delegate c = PreKey1_Deleg (PreKey1Cont c)++-- | Key with single child+prekey1WithChild :: (TrTrKey y ~ TrTrKey x, TreeTrieKeyable y) => TrTrKey x -> y -> PreKey1 x+prekey1WithChild k c = PreKey1 k (PreKey1Cont c)++-- | Key with children+prekey1WithChildren :: (TrTrKey y ~ TrTrKey x, TreeTrieKeyable y) => TrTrKey x -> [y] -> PreKey1 x+prekey1WithChildren k cs = PreKey1 k (PreKey1Conts cs)++-- | Key with 2 children+prekey1With2Children :: (TrTrKey y1 ~ TrTrKey x, TrTrKey y2 ~ TrTrKey x, TreeTrieKeyable y1, TreeTrieKeyable y2) => TrTrKey x -> y1 -> y2 -> PreKey1 x+prekey1With2Children k c1 c2 = PreKey1 k (PreKey1Cont2 c1 c2)++-------------------------------------------------------------------------------------------+--- TreeTrie structure+-------------------------------------------------------------------------------------------++-- | Child structure+type TreeTrieChildren k v+  = Map.Map (Key1 k) (TreeTrie k v)++type TTCtxt a = (Ord a)++-- | 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 :: TTCtxt k => TreeTrie k v+emptyTreeTrie = TreeTrie Nothing Lk.empty++empty = emptyTreeTrie++instance (TTCtxt k, Show k, Show v) => Show (TreeTrie k v) where+  showsPrec _ t = showList $ toListByKey t++instance (TTCtxt k, PP k, PP v) => PP (TreeTrie k v) where+  pp t = ppBracketsCommasBlock $ map (\(a,b) -> a >#< ":" >#< b) $ toListByKey t++-------------------------------------------------------------------------------------------+--- Conversion+-------------------------------------------------------------------------------------------++-- Reconstruction of original key-value pairs.++toFastSeqSubsWith :: TTCtxt k => (Key k -> v -> v') -> TreeTrieChildren k v -> Seq.FastSeq v'+toFastSeqSubsWith mk ttries+  = mconcat+      [ toFastSeqWith (\(Key ks) v -> mk (Key $ k:ks) v) True t+      | (k,t) <- Lk.toList ttries+      ]++toFastSeqSubs :: TTCtxt k => TreeTrieChildren k v -> Seq.FastSeq (Key k, v)+toFastSeqSubs = toFastSeqSubsWith (,)++toFastSeqWith :: TTCtxt k => (Key k -> v -> v') -> Bool -> TreeTrie k v -> Seq.FastSeq v'+toFastSeqWith mk inclEmpty ttrie+  =           (case ttrieMbVal ttrie of+                 Just v | inclEmpty -> Seq.singleton $ mk (Key []) v+                 _                  -> Seq.empty+              )+    `mappend` toFastSeqSubsWith mk (ttrieSubs ttrie)++toFastSeq :: TTCtxt k => Bool -> TreeTrie k v -> Seq.FastSeq (Key k, v)+toFastSeq = toFastSeqWith (,)++toListByKey, toList :: TTCtxt k => TreeTrie k v -> [(Key k,v)]+toListByKey = Seq.toList . toFastSeq True++toList = toListByKey++fromListByKeyWith :: Ord k => (v -> v -> v) -> [(Key k,v)] -> TreeTrie k v+fromListByKeyWith cmb = unionsWith cmb . map (uncurry singleton)++fromListByKey :: Ord k => [(Key k,v)] -> TreeTrie k v+fromListByKey = unions . map (uncurry singleton)++fromListWith :: Ord k => (v -> v -> v) -> [(Key k,v)] -> TreeTrie k v+fromListWith cmb = fromListByKeyWith cmb++fromList :: Ord k => [(Key k,v)] -> TreeTrie k v+fromList = fromListByKey++-------------------------------------------------------------------------------------------+--- Lookup+-------------------------------------------------------------------------------------------++type LkRes v = (Seq.FastSeq v, Seq.FastSeq v, Maybe v)++-- | Lookup giving back possible precise result and values found whilst descending into trie (corresponding to wildcard in key in trie) and remaining when key is exhausted (corresponding to wildcard in key)+lookupWith :: Ord k => (Key k -> v -> v') -> Key k -> TreeTrie k v -> LkRes v'+lookupWith mkRes keys ttrie = case unKey keys of+    [] -> (mempty, toFastSeqWith mkRes True ttrie, fmap (mkRes $ Key []) $ ttrieMbVal ttrie)+    (k : ks)+       -> case Lk.lookup k $ ttrieSubs ttrie of+            Just ttrie'+              -> (pp `mappend` p, s, m)+              where (p, s, m) = lookupWith (\(Key ks) v -> mkRes (Key (k : ks)) v) (Key ks) ttrie'+            _ -> (pp, mempty, Nothing)+       where pp = maybe mempty (Seq.singleton . mkRes (Key [])) (ttrieMbVal ttrie)++-- | Lookup giving back possible precise result and values found whilst descending into trie (corresponding to wildcard in key in trie) and remaining when key is exhausted (corresponding to wildcard in key)+lookup :: Ord k => Key k -> TreeTrie k v -> LkRes v+lookup = lookupWith $ \_ v -> v++-- | Convert the lookup result to a list of results+lookupResultToList :: LkRes v -> [v]+lookupResultToList (p,s,mv) = maybeToList mv ++ Seq.toList (p `mappend` s)+++-------------------------------------------------------------------------------------------+--- Observation+-------------------------------------------------------------------------------------------+++isEmpty :: TTCtxt k => TreeTrie k v -> Bool+isEmpty ttrie+  =  isNothing (ttrieMbVal ttrie)+  && Lk.null  (ttrieSubs ttrie)++null :: TTCtxt k => TreeTrie k v -> Bool+null = isEmpty++-------------------------------------------------------------------------------------------+--- Construction+-------------------------------------------------------------------------------------------++singleton :: Ord k => Key k -> v -> TreeTrie k v+singleton (Key keys) val+  = s keys+  where s []       = TreeTrie (Just val) Lk.empty+        s (k : ks) = TreeTrie Nothing (Lk.singleton k $ singleton (Key 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        = Lk.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) -> Key k -> v -> TreeTrie k v -> TreeTrie k v+insertByKeyWith cmb keys val ttrie = unionsWith cmb [singleton keys val,ttrie]++insertByKey :: Ord k => Key k -> v -> TreeTrie k v -> TreeTrie k v+insertByKey = insertByKeyWith const++insert :: Ord k => Key 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++-------------------------------------------------------------------------------------------+--- Instances: Serialize+-------------------------------------------------------------------------------------------++{-+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 (Key k) where+  sput (Key a) = sput a+  sget = liftM Key sget+  +instance (Serialize k) => Serialize (Key1 k)+-}+

@@ -0,0 +1,249 @@+{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 710+#else+{-# LANGUAGE OverlappingInstances #-}+#endif++-- | Abstractions for looking up (type) variables in structures++module CHR.Data.VarLookup+    ( VarLookupKey+    , VarLookupVal+    , VarLookup(..)++    -- , varlookupResolveVarWithMetaLev+    -- , varlookupResolveVar+    -- , varlookupResolveValWithMetaLev+    -- , varlookupResolveVal+    -- +    -- -- , VarCompareHow(..)+    -- +    -- , varlookupMap+    -- +    -- , varlookupResolveAndContinueM+    -- +    -- , VarLookupFix, varlookupFix+    -- , varlookupFixDel+    -- +    -- , VarLookupCmb (..)     -- 20170107 TBD: should not be both, VarLookupCmb to be replaced by LookupApply+    , LookupApply(..)+    -- +    -- -- , VarLookupBase (..)+    -- +    -- , VarLookupCmbFix, varlookupcmbFix+    -- +    , MetaLev+    , metaLevVal+    -- +    , StackedVarLookup -- (..)+    +    )+  where++-- import           Control.Applicative+-- import           Data.Maybe+-- import           CHR.Pretty+import           CHR.Data.Lookup.Stacked+import           CHR.Data.Lookup.Types      as Lk+import qualified Data.Set as Set++-------------------------------------------------------------------------------------------+--- Level of lookup+-------------------------------------------------------------------------------------------++-- | Level to lookup into+type MetaLev = Int++-- | Base level (of values, usually)+metaLevVal :: MetaLev+metaLevVal = 0++-------------------------------------------------------------------------------------------+--- VarLookup: something which can lookup a value 'v' given a key 'k'.+-------------------------------------------------------------------------------------------+++-- | Type family for key of a VarLookup+type family VarLookupKey m :: *+-- | Type family for value of a VarLookup+type family VarLookupVal m :: *++{- |+VarLookup abstracts from a Map.+The purpose is to be able to combine maps only for the purpose of searching without actually merging the maps.+This then avoids the later need to unmerge such mergings.+The class interface serves to hide this.+-}++class VarLookup m where+  -- | Lookup a key at a level+  varlookupWithMetaLev :: MetaLev -> VarLookupKey m -> m -> Maybe (VarLookupVal m)++  -- | Lookup a key+  varlookup :: VarLookupKey m -> m -> Maybe (VarLookupVal m)+  varlookup = varlookupWithMetaLev metaLevVal+  {-# INLINE varlookup #-}+  +  -- | Keys at a level+  varlookupKeysSetWithMetaLev :: (Ord (VarLookupKey m)) => MetaLev -> m -> Set.Set (VarLookupKey m)+  +  -- | Keys as Set+  varlookupKeysSet :: (Ord (VarLookupKey m)) => m -> Set.Set (VarLookupKey m)+  varlookupKeysSet = varlookupKeysSetWithMetaLev metaLevVal+  {-# INLINE varlookupKeysSet #-}++  -- | Make an empty VarLookup+  varlookupEmpty :: m+  -- | Make a singleton VarLookup at a level+  varlookupSingletonWithMetaLev :: MetaLev -> VarLookupKey m -> VarLookupVal m -> m+  +  -- | Make a singleton VarLookup+  varlookupSingleton :: VarLookupKey m -> VarLookupVal m -> m+  varlookupSingleton = varlookupSingletonWithMetaLev metaLevVal+  {-# INLINE varlookupSingleton #-}++-------------------------------------------------------------------------------------------+--- Util/convenience+-------------------------------------------------------------------------------------------++{-+-- | Combine lookup with map; should be obsolete...+varlookupMap :: VarLookup m => (VarLookupVal m -> Maybe res) -> VarLookupKey m -> m -> Maybe res+varlookupMap get k m = varlookup k m >>= get+{-# INLINE varlookupMap #-}+-}++-------------------------------------------------------------------------------------------+--- Lookup and resolution+-------------------------------------------------------------------------------------------++{-+-- | Fully resolve lookup+varlookupResolveVarWithMetaLev :: VarLookup m => MetaLev -> (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupKey m -> m -> Maybe (VarLookupVal m)+varlookupResolveVarWithMetaLev l isVar k m =+  varlookupWithMetaLev l k m >>= \v -> varlookupResolveValWithMetaLev l isVar v m <|> return v++-- | Fully resolve lookup+varlookupResolveVar :: VarLookup m => (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupKey m -> m -> Maybe (VarLookupVal m)+varlookupResolveVar = varlookupResolveVarWithMetaLev metaLevVal+{-# INLINE varlookupResolveVar #-}++varlookupResolveValWithMetaLev :: VarLookup m => MetaLev -> (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupVal m -> m -> Maybe (VarLookupVal m)+varlookupResolveValWithMetaLev l isVar v m = isVar v >>= \k -> varlookupResolveVarWithMetaLev l isVar k m <|> return v++-- | Fully resolve lookup+varlookupResolveVal :: VarLookup m => (VarLookupVal m -> Maybe (VarLookupKey m)) -> VarLookupVal m -> m -> Maybe (VarLookupVal m)+varlookupResolveVal = varlookupResolveValWithMetaLev metaLevVal+{-# INLINE varlookupResolveVal #-}++-- | Monadically lookup a variable, resolve it, continue with either a fail or success monad continuation+varlookupResolveAndContinueM :: (Monad m, VarLookup s) => (VarLookupVal s -> Maybe (VarLookupKey s)) -> (m s) -> (m a) -> (VarLookupVal s -> m a) -> VarLookupKey s -> m a+varlookupResolveAndContinueM tmIsVar gets failFind okFind k = gets >>= \s -> maybe failFind okFind $ varlookupResolveVar tmIsVar k s+-}++-------------------------------------------------------------------------------------------+--- VarLookupFix+-------------------------------------------------------------------------------------------++{-+-- (not yet, still in use in UHC) {-# DEPRECATED VarLookupFix, varlookupFix, varlookupFixDel "As of 20160331: don't use these anymore" #-}++type VarLookupFix k v = k -> Maybe v++-- | fix looking up to be for a certain var mapping+varlookupFix :: VarLookup m => m -> VarLookupFix (VarLookupKey m) (VarLookupVal m)+varlookupFix m = \k -> varlookup k m++-- | simulate deletion+varlookupFixDel :: Ord k => [k] -> VarLookupFix k v -> VarLookupFix k v+varlookupFixDel ks f = \k -> if k `elem` ks then Nothing else f k+-}++-------------------------------------------------------------------------------------------+--- VarLookupCmb: combine VarLookups+-------------------------------------------------------------------------------------------++{- |+VarLookupCmb abstracts the 'combining' of/from a substitution.+The interface goes along with VarLookup but is split off to avoid functional dependency restrictions.+The purpose is to be able to combine maps only for the purpose of searching without actually merging the maps.+This then avoids the later need to unmerge such mergings.+-}++{-+class VarLookupCmb m1 m2 where+  (|+>) :: m1 -> m2 -> m2++infixr 7 |+>++-- build on LookupApply, if available+instance {-# OVERLAPPABLE #-} Lk.LookupApply m1 m2 => VarLookupCmb m1 m2 where+  (|+>) = Lk.apply+-}++{-+#if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPING #-}+#else+instance+#endif+  VarLookupCmb m1 m2 => VarLookupCmb m1 [m2] where+    m1 |+> (m2:m2s) = (m1 |+> m2) : m2s+-}++{-+#if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPING #-}+#else+instance+#endif+  (VarLookupCmb m1 m1, VarLookupCmb m1 m2) => VarLookupCmb [m1] [m2] where+    m1 |+> (m2:m2s) = (foldr1 (|+>) m1 |+> m2) : m2s+-}++{-+instance+  (VarLookupCmb m1 m1, VarLookupCmb m1 m2) => VarLookupCmb (StackedVarLookup m1) (StackedVarLookup m2) where+    m1 |+> StackedVarLookup (m2:m2s) = StackedVarLookup $ (foldr1 (|+>) m1 |+> m2) : m2s+-}++-------------------------------------------------------------------------------------------+--- How to do the VarLookup part of matching/unification/comparing+-------------------------------------------------------------------------------------------++{-+-- | How to match, increasingly more binding is allowed+data VarCompareHow+  = VarCompareHow_Check               -- ^ equality check only+  | VarCompareHow_Match               -- ^ also allow one-directional (left to right) matching/binding of (meta)vars+  | VarCompareHow_MatchAndWait        -- ^ also allow giving back of global vars on which we wait+  | VarCompareHow_Unify               -- ^ also allow bi-directional matching, i.e. unification+  deriving (Ord, Eq)+-}++-------------------------------------------------------------------------------------------+--- VarLookupCmbFix+-------------------------------------------------------------------------------------------++{-+{-# DEPRECATED VarLookupCmbFix, varlookupcmbFix "As of 20160331: don't use these anymore" #-}+type VarLookupCmbFix m1 m2 = m1 -> m2 -> m2++-- | fix combining up to be for a certain var mapping+varlookupcmbFix :: VarLookupCmb m1 m2 => VarLookupCmbFix m1 m2+varlookupcmbFix m1 m2 = m1 |+> m2+-}++-------------------------------------------------------------------------------------------+--- 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+type StackedVarLookup s = Stacks s++type instance VarLookupKey (StackedVarLookup s) = VarLookupKey s+type instance VarLookupVal (StackedVarLookup s) = VarLookupVal s+type instance StackedElt   (StackedVarLookup s) = s++

@@ -0,0 +1,593 @@+{- |+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 CHR.Data.VarMp+    ( VarMp'(..)+    -- , VarMp+    -- , ppVarMpV+    -- , vmiMbTy+    -- , tyAsVarMp', tyAsVarMp+    -- , varmpFilterTy+    , varmpFilter+    , varmpDel, (|\>)+    , varmpAlter+    , varmpUnion, varmpUnions+    --, varmpTyLookupCyc+    --, varmpTyLookupCyc2+    , module CHR.Data.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           CHR.Pretty+import           CHR.Data.AssocL+import           CHR.Data.VarLookup+import           CHR.Data.Lookup.Types      (Lookup)+import qualified CHR.Data.Lookup            as Lk+import           CHR.Utils+import           Control.Monad+import           Data.Typeable              (Typeable)+import           GHC.Generics++-- import           UHC.Util.Serialize+++++++data VarMp' k v+  = VarMp+      { varmpMetaLev    :: !MetaLev             -- ^ the base meta level+      , varmpMpL        :: [Map.Map k v]        -- ^ for each level a map, starting at the base meta level+      }+  deriving (Eq, Ord, Typeable, Generic)++type instance VarLookupKey (VarMp' k v) = k+type instance VarLookupVal (VarMp' k v) = v++-- get the base meta level map, ignore the others+varmpToMap :: VarMp' k v -> Map.Map k v+varmpToMap (VarMp _ (m:_)) = m+{-# INLINE varmpToMap #-}++mkVarMp :: Map.Map k v -> VarMp' k v+mkVarMp m = VarMp 0 [m]+{-# INLINE mkVarMp #-}++emptyVarMp :: VarMp' k v+emptyVarMp = mkVarMp Map.empty+{-# INLINE emptyVarMp #-}++varmpIsEmpty :: VarMp' k v -> Bool+varmpIsEmpty (VarMp {varmpMpL=l}) = all Map.null l++varmpFilter :: Ord k => (k -> v -> Bool) -> VarMp' k v -> VarMp' k v+varmpFilter f (VarMp l c) = VarMp l (map (Map.filterWithKey f) c)++varmpPartition :: Ord k => (k -> v -> Bool) -> VarMp' k v -> (VarMp' k v,VarMp' k v)+varmpPartition f (VarMp l m)+  = (VarMp l p1, VarMp l p2)+  where (p1,p2) = unzip $ map (Map.partitionWithKey f) m++(|\>) :: Ord k => VarMp' k v -> [k] -> VarMp' k v+(|\>) = flip varmpDel++-- | Delete+varmpDel :: Ord k => [k] -> VarMp' k v -> VarMp' k v+varmpDel tvL c = varmpFilter (const.not.(`elem` tvL)) c++-- | Alter irrespective of level+varmpAlter :: Ord k => (Maybe v -> Maybe v) -> k -> VarMp' k v -> VarMp' k v+varmpAlter f k (VarMp l c) = VarMp l (map (Map.alter f k) c)++-- shift up the level,+-- or down when negative, throwing away the lower levels+varmpShiftMetaLev :: MetaLev -> VarMp' k v -> VarMp' k v+varmpShiftMetaLev inc (VarMp mlev fm)+  | inc < 0   = let mlev' = mlev+inc in VarMp (mlev' `max` 0) (drop (- (mlev' `min` 0)) fm)+  | otherwise = VarMp (mlev+inc) fm++varmpIncMetaLev :: VarMp' k v -> VarMp' k v+varmpIncMetaLev = varmpShiftMetaLev 1++varmpDecMetaLev :: VarMp' k v -> VarMp' k v+varmpDecMetaLev = varmpShiftMetaLev (-1)++varmpSelectMetaLev :: [MetaLev] -> VarMp' k v -> VarMp' k v+varmpSelectMetaLev mlevs (VarMp mlev ms)+  = (VarMp mlev [ if l `elem` mlevs then m else Map.empty | (l,m) <- zip [mlev..] ms ])++-- | Extract first level map, together with a construction function putting a new map into the place of the previous one+varmpAsMap :: VarMp' k v -> (Map.Map k v, Map.Map k v -> VarMp' k v)+varmpAsMap (VarMp mlev (m:ms)) = (m, \m' -> VarMp mlev (m':ms))++-- VarMp: properties++varmpSize :: VarMp' k v -> Int+varmpSize (VarMp _ m) = sum $ map Map.size m++varmpKeys :: Ord k => VarMp' k v -> [k]+varmpKeys (VarMp _ fm) = Map.keys $ Map.unions fm++varmpKeysSet :: Ord k => VarMp' k v -> Set.Set k+varmpKeysSet (VarMp _ fm) = Set.unions $ map Map.keysSet fm++{-# DEPRECATED varmpMetaLevSingleton "Use varlookupSingletonWithMetaLev" #-}+-- | VarMp singleton+varmpMetaLevSingleton :: Ord k => MetaLev -> k -> v -> VarMp' k v+varmpMetaLevSingleton = varlookupSingletonWithMetaLev+{-# INLINE varmpMetaLevSingleton #-}++-- (not yet) {-# DEPRECATED varmpSingleton "Use varlookupSingleton" #-}+-- | VarMp singleton+varmpSingleton :: Ord k => k -> v -> VarMp' k v+varmpSingleton = varlookupSingleton+{-# INLINE varmpSingleton #-}++assocMetaLevLToVarMp :: Ord k => AssocL k (MetaLev,v) -> VarMp' k v+assocMetaLevLToVarMp l = varmpUnions [ varlookupSingletonWithMetaLev lev k v | (k,(lev,v)) <- l ]++assocLToVarMp :: Ord k => AssocL k v -> VarMp' k v+assocLToVarMp = mkVarMp . Map.fromList++{-+assocMetaLevTyLToVarMp :: Ord k => AssocL k (MetaLev,Ty) -> VarMp' k VarMpInfo+assocMetaLevTyLToVarMp = assocMetaLevLToVarMp . assocLMapElt (\(ml,t) -> (ml, VMITy t)) -- varmpUnions [ varmpMetaLevTyUnit lev v t | (v,(lev,t)) <- l ]++assocTyLToVarMp :: Ord k => AssocL k Ty -> VarMp' k VarMpInfo+assocTyLToVarMp = assocLToVarMp . assocLMapElt VMITy+-}++varmpToAssocL :: VarMp' k i -> AssocL k i+varmpToAssocL (VarMp _ []   ) = []+varmpToAssocL (VarMp _ (l:_)) = Map.toList l++{-+varmpToAssocTyL :: VarMp' k VarMpInfo -> AssocL k Ty+varmpToAssocTyL c = [ (v,t) | (v,VMITy t) <- varmpToAssocL c ]+-}++-- VarMp: combine++infixr 7 `varmpPlus`++varmpPlus :: Ord k => VarMp' k v -> VarMp' k v -> VarMp' k v+varmpPlus = Lk.apply -- (|+>) -- (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 => LookupApply (VarMp' k v) (VarMp' k v) where+  m1 `apply` 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+-}

@@ -0,0 +1,103 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-------------------------------------------------------------------------------------------+-- | Vector intended for densily filled entries close to 0, > 0.+-- In situ updates are not supposed to happen often.+-------------------------------------------------------------------------------------------++module CHR.Data.VecAlloc+  ( VecAlloc+  +  , empty+  , alter+  , lookup+  , toList+  , fromList+  , null+  )+  where++-------------------------------------------------------------------------------------------+import           Prelude                        hiding (lookup, map, null)+import qualified Data.List                      as List+import           Control.Monad+import qualified Data.Vector                    as V+import qualified Data.Vector.Mutable            as MV+import           CHR.Data.Lens+-------------------------------------------------------------------------------------------++-------------------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------------------++data Val v = Init | Noth | Val v++instance Show v => Show (Val v) where+  show (Val v) = show v+  show _       = ""++m2v :: Maybe v -> Val v+m2v = maybe Noth Val+{-# INLINE m2v #-}++v2m :: Val v -> Maybe v+v2m (Val v) = Just v+v2m _       = Nothing+{-# INLINE v2m #-}++-- | VecAlloc e+newtype VecAlloc e+  = VecAlloc+      { _vecallocVec     :: V.Vector (Val e)+      -- , _vecallocFree    :: {-# UNPACK #-} !Int+      }+  deriving Show++mkLabel ''VecAlloc++-------------------------------------------------------------------------------------------+-- VecAlloc e utils+-------------------------------------------------------------------------------------------++-- | Ensure enough free slots+ensure :: Int -> VecAlloc e -> VecAlloc e+ensure sz s@(VecAlloc {_vecallocVec=v})+  | l >= sz   = s+  | otherwise = s {_vecallocVec = v V.++ V.replicate ((sz `max` ((3 * l) `div` 2)) - l) Init}+  where l = V.length v+{-# INLINE ensure #-}++empty :: VecAlloc e+empty = VecAlloc (V.replicate 3 Init) -- 0+{-# INLINE empty #-}++alter :: (Maybe e -> Maybe e) -> Int -> VecAlloc e -> VecAlloc e+alter f k s@(VecAlloc {_vecallocVec=v})+  | k >= V.length v = maybe s (\val -> vecallocVec ^$= V.modify (\v -> MV.write v k (Val val)) $ ensure (k+1) s) $ f Nothing+  | otherwise       = let upd vv = case vv V.! k of+                                     Init  -> V.modify (\v -> MV.write v k (m2v $ f Nothing)) vv+                                     Noth  -> vv V.// [(k, m2v $ f Nothing)]+                                     Val v -> vv V.// [(k, m2v $ f $ Just v)]+                      in  vecallocVec ^$= upd $ s++lookup :: Int -> VecAlloc e -> Maybe e+lookup k (VecAlloc {_vecallocVec=v})+  | k >= V.length v = Nothing+  | otherwise       = v2m $ v V.! k++toList :: VecAlloc e -> [(Int,e)]+toList (VecAlloc {_vecallocVec=v}) = [ (i,v) | (i, Val v) <- zip [0..] $ V.toList v ]++fromList :: [(Int,e)] -> VecAlloc e+fromList [] = empty+fromList l  = vecallocVec ^$= V.modify (\v -> forM_ l $ \(k,x) -> MV.write v k (Val x)) $ ensure (mx+1) empty+  where mx = maximum $ List.map fst l++null :: VecAlloc e -> Bool+null = List.null . toList++{-+unionWith :: (e -> e -> e) -> VecAlloc e -> VecAlloc e -> VecAlloc e+unionWith f (VecAlloc {_vecallocVec=v1}) (VecAlloc {_vecallocVec=v2})+-}

@@ -0,0 +1,653 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances, DefaultSignatures, UndecidableInstances #-}++{-| Various utils. Relic of the past, requires adaption to newer general purpose libs+ -}++module CHR.Utils+  ( +  {-+    -- * Set+    unionMapSet++    -- * Map+  , inverseMap+  , showStringMapKeys+  +  , mapLookup2', mapLookup2+  +    -- * List+  , hdAndTl', hdAndTl+  -}+    maybeNull+  , maybeHd+  {-+  , wordsBy+  , initlast, initlast2+  , last'+  , firstNotEmpty+  , listSaturate, listSaturateWith+  , spanOnRest+  , filterMb+  -}+  , splitPlaces+  , combineToDistinguishedEltsBy+  {-+  , partitionOnSplit+  -}+  , zipWithN+  {-+  +    -- * Tuple+  , tup123to1, tup123to2+  , tup123to12, tup123to23+  , tup12to123+  +  , fst3+  , snd3+  , thd3+  , thd +  +  , tup1234to1  +  , tup1234to2  +  , tup1234to3  +  , tup1234to4  +  +  , tup1234to12+  , tup1234to13+  , tup1234to14+  , tup1234to23+  , tup1234to24+  , tup1234to34+  +  , tup1234to123+  , tup1234to234+  +  , tup1234to124+  , tup1234to134+  +  , tup123to1234+ +  , fst4+  , snd4+  , thd4+  , fth4+  , fth +  +    -- * String+  , strWhite+  , strPad+  , strCapitalize+  , strToLower+  , strToInt+  +  , splitForQualified+  +    -- * Show utils+  , showUnprefixedWithShowTypeable+  , DataAndConName(..)+  , showUnprefixed+  +    -- * Ordering+    -}+  , orderingLexic+  , orderingLexicList+  +  {-+    -- * Misc+  -}+  , panic+  , isSortedByOn+  , sortOnLazy+  , sortOn+  , sortByOn+  , groupOn+  , groupByOn+  , groupSortOn+  , groupSortByOn+  {-+  , nubOn+  +  , consecutiveBy+  +  , partitionAndRebuild+  -}+    -- * Maybe+  , panicJust+  {-+  , ($?)+  , orMb+  , maybeAnd+  , maybeOr+  +    -- * Graph+  -- , scc+  +    -- * Monad+  , firstMaybeM+  , breakM+  -}+  )+  where++import Data.Char+import Data.List+import Data.Maybe+import Data.Function+import Data.Typeable+import GHC.Generics+import qualified Data.Set as Set+import qualified Data.Map as Map+-- import qualified Data.Graph as Graph++{-++-------------------------------------------------------------------------+-- Set+-------------------------------------------------------------------------++-- | Union a set where each element itself is mapped to a set+unionMapSet :: Ord b => (a -> Set.Set b) -> (Set.Set a -> Set.Set b)+unionMapSet f = Set.unions . map f . Set.toList++-------------------------------------------------------------------------+-- Map+-------------------------------------------------------------------------++-- | Inverse of a map+inverseMap :: (Ord k, Ord v') => (k -> v -> (v',k')) -> Map.Map k v -> Map.Map v' k'+inverseMap mk = Map.fromList . map (uncurry mk) . Map.toList++-- | Show keys of map using a separator+showStringMapKeys :: Map.Map String x -> String -> String+showStringMapKeys m sep = concat $ intersperse sep $ Map.keys m+-}++-------------------------------------------------------------------------+-- List+-------------------------------------------------------------------------++{-+-- | Get head and tail, with default if empty list+hdAndTl' :: a -> [a] -> (a,[a])+hdAndTl' _ (a:as) = (a,as)+hdAndTl' n []     = (n,[])++-- | Get head and tail, with panic/error if empty list+hdAndTl :: [a] -> (a,[a])+hdAndTl = hdAndTl' (panic "hdAndTl")+{-# INLINE hdAndTl  #-}+-}++maybeNull :: r -> ([a] -> r) -> [a] -> r+maybeNull n f l = if null l then n else f l+{-# INLINE maybeNull  #-}++maybeHd :: r -> (a -> r) -> [a] -> r+maybeHd n f = maybeNull n (f . head)+{-# INLINE maybeHd  #-}++{-+-- | Split up in words by predicate+wordsBy :: (a -> Bool) -> [a] -> [[a]]+wordsBy p l+  = w l+  where w [] = []+        w l  = let (l',ls') = break p l+               in  l' : case ls' of []       -> []+                                    (_:[])   -> [[]]+                                    (_:ls'') -> w ls''++-- | Possibly last element and init+initlast :: [a] -> Maybe ([a],a)+initlast as+  = il [] as+  where il acc [a]    = Just (reverse acc,a)+        il acc (a:as) = il (a:acc) as+        il _   _      = Nothing++-- | variation on last which returns empty value instead of+last' :: a -> [a] -> a+last' e = maybe e snd . initlast++-- | Possibly last and preceding element and init+initlast2 :: [a] -> Maybe ([a],a,a)+initlast2 as+  = il [] as+  where il acc [a,b]  = Just (reverse acc,a,b)+        il acc (a:as) = il (a:acc) as+        il _   _      = Nothing++-- | First non empty list of list of lists+firstNotEmpty :: [[x]] -> [x]+firstNotEmpty = maybeHd [] id . filter (not . null)++-- | Saturate a list, that is:+-- for all indices i between min and max,+-- if there is no listelement x for which  get x  returns i,+-- add an element  mk i  to the list+listSaturate :: (Enum a,Ord a) => a -> a -> (x -> a) -> (a -> x) -> [x] -> [x]+listSaturate min max get mk xs+  = [ Map.findWithDefault (mk i) i mp | i <- [min..max] ]+  where mp = Map.fromList [ (get x,x) | x <- xs ]++-- | Saturate a list with values from assoc list, that is:+-- for all indices i between min and max,+-- if there is no listelement x for which  get x  returns i,+-- add a candidate from the associationlist (which must be present) to the list+listSaturateWith :: (Enum a,Ord a) => a -> a -> (x -> a) -> [(a,x)] -> [x] -> [x]+listSaturateWith min max get missing l+  = listSaturate min max get mk l+  where mp = Map.fromList missing+        mk a = panicJust "listSaturateWith" $ Map.lookup a mp++-- variant on span, predicate on full list+spanOnRest :: ([a] -> Bool) -> [a] -> ([a],[a])+spanOnRest p []       = ([],[])+spanOnRest p xs@(x:xs')+     | p xs      = (x:ys, zs)+     | otherwise = ([],xs)+                       where (ys,zs) = spanOnRest p xs'++-- | variant on 'filter', where predicate also yields a result+filterMb :: (a -> Maybe b) -> [a] -> [b]+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++zipWithN :: ([x] -> y) -> [[x]] -> [y]+zipWithN f l | any null l = []+             | otherwise  = f (map head l) : zipWithN f (map tail l)++{-++-------------------------------------------------------------------------+-- Tupling, untupling+-------------------------------------------------------------------------++tup123to1  (a,_,_) = a+tup123to2  (_,a,_) = a+tup123to3  (_,_,a) = a+{-# INLINE tup123to1  #-}+{-# INLINE tup123to2  #-}+{-# INLINE tup123to3  #-}++tup123to12 (a,b,_) = (a,b)+tup123to23 (_,a,b) = (a,b)+{-# INLINE tup123to12 #-}+{-# INLINE tup123to23 #-}++tup12to123 c (a,b) = (a,b,c)+{-# INLINE tup12to123 #-}++fst3 = tup123to1+snd3 = tup123to2+thd3 = tup123to3+thd  = thd3+{-# INLINE fst3 #-}+{-# INLINE snd3 #-}+{-# INLINE thd3 #-}+{-# INLINE thd  #-}++tup1234to1   (a,_,_,_) = a+tup1234to2   (_,a,_,_) = a+tup1234to3   (_,_,a,_) = a+tup1234to4   (_,_,_,a) = a+{-# INLINE tup1234to1   #-}+{-# INLINE tup1234to2   #-}+{-# INLINE tup1234to3   #-}+{-# INLINE tup1234to4   #-}++tup1234to12  (a,b,_,_) = (a,b)+tup1234to13  (a,_,b,_) = (a,b)+tup1234to14  (a,_,_,b) = (a,b)+tup1234to23  (_,a,b,_) = (a,b)+tup1234to24  (_,a,_,b) = (a,b)+tup1234to34  (_,_,a,b) = (a,b)+{-# INLINE tup1234to12 #-}+{-# INLINE tup1234to13 #-}+{-# INLINE tup1234to14 #-}+{-# INLINE tup1234to23 #-}+{-# INLINE tup1234to24 #-}+{-# INLINE tup1234to34 #-}++tup1234to123 (a,b,c,_) = (a,b,c)+tup1234to234 (_,a,b,c) = (a,b,c)+{-# INLINE tup1234to123 #-}+{-# INLINE tup1234to234 #-}++tup1234to124 (a,b,_,c) = (a,b,c)+tup1234to134 (a,_,b,c) = (a,b,c)+{-# INLINE tup1234to124 #-}+{-# INLINE tup1234to134 #-}++tup123to1234 d (a,b,c) = (a,b,c,d)+{-# INLINE tup123to1234 #-}++fst4 = tup1234to1+snd4 = tup1234to2+thd4 = tup1234to3+fth4 = tup1234to4+fth  = fth4+{-# INLINE fst4 #-}+{-# INLINE snd4 #-}+{-# INLINE thd4 #-}+{-# INLINE fth4 #-}+{-# INLINE fth  #-}+++-------------------------------------------------------------------------+-- String+-------------------------------------------------------------------------++-- | Blanks+strWhite :: Int -> String+strWhite sz = replicate sz ' '+{-# INLINE strWhite #-}++-- | Pad upto size with blanks+strPad :: String -> Int -> String+strPad s sz = s ++ strWhite (sz - length s)++-- | Capitalize first letter+strCapitalize :: String -> String+strCapitalize s+  = case s of+      (c:cs) -> toUpper c : cs+      _      -> s++-- | Lower case+strToLower :: String -> String+strToLower = map toLower+{-# INLINE strToLower #-}++-- | Convert string to Int+strToInt :: String -> Int+strToInt = foldl (\i c -> i * 10 + ord c - ord '0') 0++-------------------------------------------------------------------------+-- Split for qualified name+-------------------------------------------------------------------------++-- | Show, additionally removing type name prefix, assuming constructor names are prefixed with type name, possibly with additional underscore (or something like that)+showUnprefixedWithShowTypeable :: (Show x, Typeable x) => Int -> x -> String+showUnprefixedWithShowTypeable extralen x = drop prelen $ show x+  where prelen = (length $ show $ typeOf x) + extralen++-- | Generic constructor name, to be used by show variations+class GDataAndConName f where+  gDataAndConName :: f x -> (String,String)++class DataAndConName x where+  -- | Get datatype and constructor name for a datatype+  dataAndConName :: x -> (String,String)+  +  default dataAndConName :: (Generic x, GDataAndConName (Rep x)) => x -> (String,String)+  dataAndConName = gDataAndConName . from++instance (Datatype d, GDataAndConName x) => GDataAndConName (D1 d x) where+  gDataAndConName d@(M1 x) = let (_,c) = gDataAndConName x in (datatypeName d, c)++instance (GDataAndConName a, GDataAndConName b) => GDataAndConName (a :+: b) where+  gDataAndConName (L1 x) = gDataAndConName x+  gDataAndConName (R1 x) = gDataAndConName x++instance (Constructor c) => GDataAndConName (C1 c x) where+  gDataAndConName c = ("", conName c)++-- | Show, additionally removing type name prefix, assuming constructor names are prefixed with type name, possibly with additional underscore (or something like that)+showUnprefixed :: (DataAndConName x) => Int -> x -> String+showUnprefixed extralen x = drop prelen $ c+  where (d,c) = dataAndConName x+        prelen = (length d) + extralen++-------------------------------------------------------------------------+-- Split for qualified name+-------------------------------------------------------------------------++-- | Split into fragments based on '.' convention for qualified Haskell names+splitForQualified :: String -> [String]+splitForQualified s+    = ws''+    where ws  = wordsBy (=='.') s+          ws' = case initlast2 ws of+                  Just (ns,n,"") -> ns ++ [n ++ "."]+                  _              -> ws+          ws''= case break (=="") ws' of+                  (nq,(_:ns)) -> nq ++ [concatMap ("."++) ns]+                  _ -> ws'++-}+++-------------------------------------------------------------------------+-- Misc+-------------------------------------------------------------------------++-- | Error, with message+panic m = error ("panic: " ++ m)++-------------------------------------------------------------------------+-- group/sort/nub combi's+-------------------------------------------------------------------------++isSortedByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> Bool+isSortedByOn cmp sel l+  = isSrt l+  where isSrt (x1:tl@(x2:_)) = cmp (sel x1) (sel x2) /= GT && isSrt tl+        isSrt _              = True++-- | A slightly more lazy version of Data.List.sortOn.+-- See also https://github.com/UU-ComputerScience/uhc-util/issues/5 .+sortOnLazy :: Ord b => (a -> b) -> [a] -> [a]+sortOnLazy = sortByOn compare+{-# INLINE sortOnLazy #-}++#if __GLASGOW_HASKELL__ >= 710+#else+-- | The original Data.List.sortOn.+-- See also https://github.com/UU-ComputerScience/uhc-util/issues/5 .+sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn = sortOnLazy+{-# INLINE sortOn #-}+#endif+++sortByOn :: (b -> b -> Ordering) -> (a -> b) -> [a] -> [a]+sortByOn cmp sel = sortBy (cmp `on` sel) -- (\e1 e2 -> sel e1 `cmp` sel e2)++groupOn :: Eq b => (a -> b) -> [a] -> [[a]]+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 (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 ((==) `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]]+consecutiveBy _        []      =  []+consecutiveBy isConsec (x:xs)  =  ys : consecutiveBy isConsec zs+  where (ys,zs) = consec x xs+        consec x []                        = ([x],[])+        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+-------------------------------------------------------------------------++-- | Partition, but also return a function which will rebuild according to the original ordering of list elements+partitionAndRebuild :: (v -> Bool) -> [v] -> ([v], [v], [v'] -> [v'] -> [v'])+partitionAndRebuild f (v:vs)+  | f v                  = (v : vs1,     vs2, \(r:r1)   r2  -> r : mk r1 r2)+  | otherwise            = (    vs1, v : vs2, \   r1 (r:r2) -> r : mk r1 r2)+  where (vs1,vs2,mk) = partitionAndRebuild f vs+partitionAndRebuild _ [] = ([], [], \_ _ -> [])++-}++-------------------------------------------------------------------------+-- Ordering+-------------------------------------------------------------------------++-- | Reduce compare results lexicographically to one compare result+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+-------------------------------------------------------------------------+++panicJust :: String -> Maybe a -> a+panicJust m = maybe (panic m) id+{-# INLINE panicJust #-}++{-+infixr 0  $?++($?) :: (a -> Maybe b) -> Maybe a -> Maybe b+f $? mx = do x <- mx+             f x++orMb :: Maybe a -> Maybe a -> Maybe a+orMb m1 m2 = maybe m2 (const m1) m1+-- orMb = maybeOr Nothing Just Just++maybeAnd :: x -> (a -> b -> x) -> Maybe a -> Maybe b -> x+maybeAnd n jj ma mb+  = case ma of+      Just a+        -> case mb of {Just b -> jj a b ; _ -> n}+      _ -> n++maybeOr :: x -> (a -> x) -> (b -> x) -> Maybe a -> Maybe b -> x+maybeOr n fa fb ma mb+  = case ma of+      Just a -> fa a+      _      -> case mb of+                  Just b -> fb b+                  _      -> n++-}++-------------------------------------------------------------------------+-- Strongly Connected Components+-------------------------------------------------------------------------++{-+scc :: Ord n => [(n,[n])] -> [[n]]+scc = map Graph.flattenSCC . Graph.stronglyConnComp . map (\(n,ns) -> (n, n, ns))+-}++{-+-------------------------------------------------------------------------+-- Map+-------------------------------------------------------------------------++-- | double lookup, with transformer for 2nd map+mapLookup2' :: (Ord k1, Ord k2) => (v1 -> Map.Map k2 v2) -> k1 -> k2 -> Map.Map k1 v1 -> Maybe (Map.Map k2 v2, v2)+mapLookup2' f k1 k2 m1+  = do m2 <- Map.lookup k1 m1+       let m2' = f m2+       fmap ((,) m2') $ Map.lookup k2 m2'++-- | double lookup+mapLookup2 :: (Ord k1, Ord k2) => k1 -> k2 -> Map.Map k1 (Map.Map k2 v2) -> Maybe v2+mapLookup2 k1 k2 m1 = fmap snd $ mapLookup2' id k1 k2 m1+{-# INLINE mapLookup2 #-}++-------------------------------------------------------------------------+-- Monad+-------------------------------------------------------------------------++-- | loop over monads yielding a Maybe from a start value, yielding the first Just or the start (when no Just is returned)+firstMaybeM :: Monad m => a -> [a -> m (Maybe a)] -> m a+firstMaybeM x []     = return x+firstMaybeM x (s:ss) = do mx <- s x+                          maybe (firstMaybeM x ss) return mx++-- | Monadic equivalent of break: evaluate monads until a predicate is True, returning what is yes/no evaluated and the split point+breakM :: Monad m => (a -> Bool) -> [m a] -> m ([a], Maybe (a,[m a]))+breakM p l = br [] l >>= \(acc,res) -> return (reverse acc, res)+  where br acc []     = return (acc, Nothing)+        br acc (m:ms) = m >>= \x -> if p x then return (acc, Just (x, ms)) else br (x:acc) ms++-}++