context-stack (empty) → 0.1.0.0

raw patch · 4 files changed

+187/−0 lines, 4 filesdep +basedep +classy-preludedep +data-defaultsetup-changed

Dependencies added: base, classy-prelude, data-default, mtl, unordered-containers

Files

LICENSE +20/−0
Setup.hs +2/−0
context-stack.cabal +25/−0
src/Data/ContextStack.hs +140/−0

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2014 Allen Nelson++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ Setup.hs view

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

+ context-stack.cabal view

@@ -0,0 +1,25 @@+-- Initial monad-stack.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                context-stack+version:             0.1.0.0+synopsis:            An abstraction of a stack and stack-based monadic context.+-- description:+homepage:            http://github.com/thinkpad20/context-stack+license:             MIT+license-file:        LICENSE+author:              Allen Nelson+maintainer:          ithinkican@gmail.com+-- copyright:+category:            Data+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  exposed-modules:     Data.ContextStack+  -- other-modules:+  other-extensions:    NoImplicitPrelude, TypeFamilies, FlexibleContexts, LambdaCase, OverloadedStrings+  build-depends:       base >=4.7 && <4.8, classy-prelude, unordered-containers, mtl, data-default+  hs-source-dirs:      src+  default-language:    Haskell2010

+ src/Data/ContextStack.hs view

@@ -0,0 +1,140 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.ContextStack (+    Stack(..), KeyValueStore(..),+    withFrame, withBindings, modifyTopM, store, buildMap, loadBindingsM,+    find, findOnTop, findOrError, findOrHardError, topFrame+  ) where++import qualified Prelude as P+import qualified Data.HashMap.Strict as H+import Data.Default+import Control.Monad.State.Strict+import Control.Monad.Except+import ClassyPrelude hiding (find, asList)++-- | An abstract stack, supporting push/pop.+class Stack s where+  -- | Frames are things which appear in a stack.+  type family Frame s :: *+  -- | Pushing onto the stack.+  push :: Frame s -> s -> s+  -- | Popping off of the stack.+  pop :: s -> (Frame s, s)+  -- | Viewing the stack as a list of frames.+  asList :: s -> [Frame s]+  -- | Applying a function to the top of the stack.+  modifyTop :: (Frame s -> Frame s) -> s -> s++-- | Lists are stacks, of course.+instance Stack [a] where+  type Frame [a] = a+  push = (:)+  pop (x:xs) = (x, xs)+  asList = id+  modifyTop func (x:xs) = func x : xs++-- | Gets the top frame of the stack.+topFrame :: Stack s => s -> Frame s+topFrame = P.head . asList++-- | Pushing in the state monad.+pushM :: (Stack s, MonadState s m) => Frame s -> m ()+pushM = modify . push++-- | Popping in the state monad.+popM :: (Stack s, MonadState s m) => m (Frame s)+popM = gets pop >>= \(top, newstack) -> put newstack >> return top++-- | Modifying the top in the state monad.+modifyTopM :: (Stack s, MonadState s m) => (Frame s -> Frame s) -> m ()+modifyTopM = modify . modifyTop++-- | An abstract key-value store.+class KeyValueStore s where+  -- | The keys of the store.+  type family LookupKey s :: *+  -- | The values of the store.+  type family StoredValue s :: *+  -- | An empty "default" map.+  empty :: s+  -- | Looking up a value.+  getValue :: LookupKey s -> s -> Maybe (StoredValue s)+  -- | Inserting a value.+  putValue :: LookupKey s -> StoredValue s -> s -> s+  -- | Loading bindings from a hashmap.+  loadBindings :: HashMap (LookupKey s) (StoredValue s) -> s -> s++-- | HashMaps are key-value stores.+instance (Hashable key, Eq key) => KeyValueStore (HashMap key val) where+  type LookupKey (HashMap key val) = key+  type StoredValue (HashMap key val) = val+  empty = H.empty+  putValue = H.insert+  getValue = H.lookup+  loadBindings = H.union++-- | Converts a list into a `KeyValueStore`.+buildMap :: (Default s, KeyValueStore s, MonoFoldable collection,+               Element collection ~ (LookupKey s, StoredValue s))+            => collection -> s+buildMap = foldr (uncurry putValue) def++-- | Stores @name => item@ on the top of the stack.+store :: (Stack s, KeyValueStore (Frame s), MonadState s m)+      => LookupKey (Frame s) -> StoredValue (Frame s) -> m ()+store key item = modifyTopM $ putValue key item++loadBindingsM :: (Stack s, KeyValueStore (Frame s), MonadState s m)+              => HashMap (LookupKey (Frame s)) (StoredValue (Frame s)) -> m ()+loadBindingsM map = modifyTopM $ loadBindings map++-- | Looks up @key@ somewhere in the stack, starting from the top.+find :: (Stack s, KeyValueStore (Frame s), MonadState s m)+     => LookupKey (Frame s) -> m (Maybe (StoredValue (Frame s)))+find key = gets asList >>= go where+  go [] = return Nothing+  go (top:rest) = case getValue key top of+    Nothing -> go rest+    Just result -> return $ Just result++-- | Looks up @key@ on the top of the stack only.+findOnTop :: (Stack s, KeyValueStore (Frame s), MonadState s m)+          => LookupKey (Frame s) -> m (Maybe (StoredValue (Frame s)))+findOnTop key = gets asList >>= \case+  [] -> return Nothing+  top:_ -> return $ getValue key top++-- | Finds an identifier in the current scope, or throws an error.+findOrError :: (Stack s, KeyValueStore (Frame s), MonadState s m,+                MonadError e m)+            => e -- * Error to throw+            -> LookupKey (Frame s)        -- * Key to look up+            -> m (StoredValue (Frame s))  -- * Result+findOrError err key = find key >>= \case+  Nothing -> throwError err+  Just result -> return result++-- | Finds an identifier in the current scope, or throws an IO error.+findOrHardError :: (Stack s, KeyValueStore (Frame s), MonadState s m,+                    Show (LookupKey (Frame s)))+                => LookupKey (Frame s)             -- * The key to look up+                -> m (StoredValue (Frame s))       -- * The retrieved value+findOrHardError key = find key >>= \case+  Nothing -> error $ concat ["Key ", show key, " not found"]+  Just result -> return result++-- | Performs an action with the given frame on the top of the stack.+withFrame :: (Stack s, MonadState s m, Applicative m)+          => Frame s -> m a -> m a+withFrame elem action = pushM elem *> action <* popM++-- | Performs an action with the given bindings in scope.+withBindings :: (Stack s, KeyValueStore (Frame s), MonadState s m,+                 Applicative m, Default (Frame s), MonoFoldable collection,+                 Element collection ~ (LookupKey (Frame s), StoredValue (Frame s)))+             => collection -> m a -> m a+withBindings bindings = withFrame (buildMap bindings)