namespace (empty) → 0.1.0.0
raw patch · 6 files changed
+208/−0 lines, 6 filesdep +basedep +containersdep +namespacesetup-changed
Dependencies added: base, containers, namespace
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- namespace.cabal +34/−0
- src/Data/Namespace/Namespace.hs +99/−0
- src/Data/Namespace/Path.hs +41/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Hao Xu (c) 2016++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 Author name here 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ namespace.cabal view
@@ -0,0 +1,34 @@+name: namespace+version: 0.1.0.0+synopsis: A Generic Haskell library for managing namespaces+description: Please see README.md+homepage: https://github.com/xu-hao/namespace+license: BSD3+license-file: LICENSE+author: Hao Xu+maintainer: xuh@email.unc.edu+copyright: 2016 Hao Xu+category: Data+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Data.Namespace.Namespace Data.Namespace.Path+ build-depends: base >= 4.7 && < 5,+ containers+ default-language: Haskell2010++test-suite namespace-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , namespace+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/xu-hao/namespace
+ src/Data/Namespace/Namespace.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE RankNTypes, StandaloneDeriving, GADTs, FlexibleInstances #-}++module Data.Namespace.Namespace+ ( Namespace, lookupNamespace, lookupObject, topLevelObjects, insertObject, insertNamespace,+ importFromNamespace, importAllFromNamespace, importExceptFromNamespace,+ importQualifiedFromNamespace, importQualifiedAllFromNamespace, importQualifiedExceptFromNamespace+ ) where++import Prelude hiding (lookup)+import Data.Map.Strict+import Data.Monoid+import Data.Maybe+import Control.Monad+import Control.Applicative++import Data.Namespace.Path++data Namespace k a where+ Namespace :: Key k => Map k (Namespace k a) -> Map k a -> Namespace k a++deriving instance (Show k, Show a) => Show (Namespace k a)++lookupNamespace :: Key k => NamespacePath k -> Namespace k a -> Maybe (Namespace k a)+lookupNamespace (NamespacePath []) n = return n+lookupNamespace (NamespacePath (k : ks)) (Namespace nm om) = do+ n' <- lookup k nm+ lookupNamespace (NamespacePath ks) n'++lookupObject :: Key k => ObjectPath k -> Namespace k a -> Maybe a+lookupObject (ObjectPath np k) n = do+ (Namespace nm om) <- lookupNamespace np n+ lookup k om++instance Key k => Monoid (Namespace k a) where+ mempty = Namespace mempty mempty+ mappend (Namespace nm om) (Namespace nm2 om2) = Namespace (unionWith mappend nm nm2) (om <> om2)++topLevelObjects :: Key k => Namespace k a -> Map k a+topLevelObjects (Namespace _ om) = om++insertObject :: Key k => ObjectPath k -> a -> Namespace k a -> Namespace k a+insertObject (ObjectPath (NamespacePath []) k) o (Namespace nm om) = Namespace nm (insert k o om)+insertObject (ObjectPath (NamespacePath (k : ks)) objkey) o (Namespace nm om) =+ let nm2 = fromMaybe mempty (lookup k nm)+ nm2' = insertObject (ObjectPath (NamespacePath ks) objkey) o nm2 in+ Namespace (insert k nm2' nm) om++insertNamespace :: Key k => NamespacePath k -> Map k a -> Namespace k a -> Namespace k a+insertNamespace (NamespacePath []) om (Namespace nm2 om2) = Namespace nm2 (om <> om2)+insertNamespace (NamespacePath (k : ks)) om (Namespace nm2 om2) =+ let nm3 = fromMaybe mempty (lookup k nm2)+ nm3' = insertNamespace (NamespacePath ks) om nm3' in+ Namespace (insert k nm3' nm2) om++importAllFromNamespace :: Key k => NamespacePath k -> Namespace k a -> Namespace k a -> Maybe (Namespace k a)+importAllFromNamespace np n (Namespace nm2 om2) = do+ n' <- lookupNamespace np n+ return (Namespace nm2 (topLevelObjects n' <> om2))++importFromNamespace :: Key k => NamespacePath k -> [k] -> Namespace k a -> Namespace k a -> Maybe (Namespace k a)+importFromNamespace np keys n (Namespace nm2 om2) = do+ n' <- lookupNamespace np n+ let om = topLevelObjects n'+ Namespace nm2 <$> foldM (\om2' key -> do+ o <- lookup key om+ return (insert key o om2')) om2 keys++importExceptFromNamespace :: Key k => NamespacePath k -> [k] -> Namespace k a -> Namespace k a -> Maybe (Namespace k a)+importExceptFromNamespace np keys n (Namespace nm2 om2) = do+ n' <- lookupNamespace np n+ let om = topLevelObjects n'+ return (Namespace nm2 (foldlWithKey (\om2' key o ->+ if key `elem` keys+ then om2'+ else insert key o om2') om2 om))++importQualifiedAllFromNamespace :: Key k => NamespacePath k -> Namespace k a -> Namespace k a -> Maybe (Namespace k a)+importQualifiedAllFromNamespace p n n2 = do+ n' <- lookupNamespace p n+ return (insertNamespace p (topLevelObjects n') n2)++importQualifiedFromNamespace :: Key k => NamespacePath k -> [k] -> Namespace k a -> Namespace k a -> Maybe (Namespace k a)+importQualifiedFromNamespace p keys n n2 = do+ n' <- lookupNamespace p n+ let om = topLevelObjects n'+ om' <- foldM (\om2' key -> do+ o <- lookup key om+ return (insert key o om2')) mempty keys+ return (insertNamespace p om' n2)++importQualifiedExceptFromNamespace :: Key k => NamespacePath k -> [k] -> Namespace k a -> Namespace k a -> Maybe (Namespace k a)+importQualifiedExceptFromNamespace p keys n n2 = do+ n' <- lookupNamespace p n+ let om = topLevelObjects n'+ let om' = foldlWithKey (\om2' key o ->+ if key `elem` keys+ then om2'+ else insert key o om2') mempty om+ return (insertNamespace p om' n2)
+ src/Data/Namespace/Path.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE RankNTypes, GADTs, StandaloneDeriving, FlexibleInstances, PatternSynonyms #-}++module Data.Namespace.Path+ ( NamespacePath(..), ObjectPath(..), extendNamespacePath, concatNamespacePathWithObjectPath, qualified, Key,+ ) where++import Prelude hiding (lookup)+import Data.Map.Strict+import Data.Monoid++class Ord k => Key k where++data NamespacePath k where+ NamespacePath :: Key k => [k] -> NamespacePath k++deriving instance Eq (NamespacePath k)+deriving instance Ord (NamespacePath k)+deriving instance Show k => Show (NamespacePath k)++instance Key (NamespacePath k) where++data ObjectPath k where+ ObjectPath :: Key k => NamespacePath k -> k -> ObjectPath k++deriving instance Eq (ObjectPath k)+deriving instance Ord (ObjectPath k)+deriving instance Show k => Show (ObjectPath k)++extendNamespacePath :: Key k => NamespacePath k -> k -> NamespacePath k+extendNamespacePath (NamespacePath p) k = NamespacePath (p <> [k])++instance Key k => Monoid (NamespacePath k) where+ mempty = NamespacePath mempty+ mappend (NamespacePath p1) (NamespacePath p2) = NamespacePath (p1 <> p2)++concatNamespacePathWithObjectPath :: Key k => NamespacePath k -> ObjectPath k -> ObjectPath k+concatNamespacePathWithObjectPath np (ObjectPath np2 k) = ObjectPath (np <> np2) k++qualified :: Key k => ObjectPath k -> Bool+qualified (ObjectPath (NamespacePath []) _) = False+qualified _ = True
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"