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
newtype Stacks l = Stacks {unStacks :: [l]}
deriving (Functor, Applicative)
type family StackedElt stk :: *
class Stacked stk where
lifts :: StackedElt stk -> stk
unlifts :: stk -> [StackedElt stk]
top :: stk -> StackedElt stk
pop :: stk -> (StackedElt stk,stk)
push :: StackedElt stk -> stk -> stk
topM :: (MonadState stk m) => m (StackedElt stk)
popM :: (MonadState stk m) => m (StackedElt stk)
pushM :: (MonadState stk m) => StackedElt stk -> m ()
tops :: stk -> stk
pops :: stk -> (stk,stk)
pushs :: stk -> stk -> stk
topsM :: (MonadState stk m) => m stk
popsM :: (MonadState stk m) => m stk
pushsM :: (MonadState stk m) => stk -> m ()
tops = lifts . top
pops = first lifts . pop
pushs = push . top
topsM = gets tops
popsM = state pops
pushsM = modify . pushs
topM = gets top
top = evalState topM
popM = state pop
pop = runState popM
pushM = modify . push
push = execState . pushM
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
keysSet = Set.unions . List.map keysSet . unStacks
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