├── .circleci └── config.yml ├── .gitignore ├── NAMES.md ├── README.md ├── graph-core ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── graph-core.cabal └── src │ ├── Data │ └── Core │ │ ├── Graph.hs │ │ └── Graph │ │ ├── NodeManager.hs │ │ ├── Persistence.hs │ │ └── PureCore.hs │ ├── Test │ ├── Arbitrary.hs │ ├── Core.hs │ ├── NodeManager.hs │ └── Persistence.hs │ └── Tests.hs ├── helper.hs ├── preview ├── LICENSE ├── README.md ├── Setup.hs ├── preview.cabal └── src │ └── Data │ └── Preview.hs ├── stack.yaml ├── strict-data ├── .DS_Store ├── LICENSE ├── README.md ├── Setup.hs ├── src │ └── Data │ │ ├── Choice.hs │ │ ├── Fail.hs │ │ ├── Fail │ │ └── Types.hs │ │ ├── Map │ │ ├── Ordered.hs │ │ └── Unordered.hs │ │ ├── Option.hs │ │ ├── StrictList.hs │ │ ├── StrictList │ │ └── Types.hs │ │ ├── StrictTuple.hs │ │ ├── StrictVector.hs │ │ └── StrictVector │ │ └── Mutable.hs ├── strict-data.cabal └── test │ ├── Data │ └── Map │ │ └── OrderedSpec.hs │ ├── Doc.hs │ ├── Fail.hs │ ├── Option.hs │ ├── Spec.hs │ ├── StrictList.hs │ ├── StrictVector.hs │ └── StrictVector │ └── Mutable.hs ├── text-plus ├── LICENSE ├── README.md ├── Setup.hs ├── src │ └── Data │ │ └── Text │ │ └── Plus.hs ├── test │ ├── Data │ │ └── Text │ │ │ └── PlusSpec.hs │ └── Spec.hs └── text-plus.cabal └── util-plus ├── LICENSE ├── README.md ├── Setup.hs ├── src ├── Control │ └── Applicative │ │ └── Plus.hs ├── Data │ └── List │ │ └── Plus.hs ├── GHC │ └── Stack │ │ └── Plus.hs └── Safe │ └── Plus.hs ├── test ├── Data │ └── List │ │ └── PlusSpec.hs ├── GHC │ └── Stack │ │ └── PlusSpec.hs ├── Safe │ └── PlusSpec.hs └── Spec.hs └── util-plus.cabal /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | working_directory: ~/opensource-mono 5 | docker: 6 | - image: fpco/stack-build:lts-8.20 7 | steps: 8 | - checkout 9 | - restore_cache: 10 | key: stack-cache 11 | - run: 12 | name: stack setup 13 | command: 'stack setup' 14 | - run: 15 | name: stack install dependencies 16 | command: 'stack build --test --only-dependencies' 17 | - save_cache: 18 | key: stack-cache 19 | paths: 20 | - ~/.stack 21 | - ~/opensource-mono/.stack-work 22 | - run: 23 | name: stack build 24 | command: 'stack build --fast --pedantic' 25 | - run: 26 | name: stack test 27 | command: 'stack test --fast' 28 | build-nightly: 29 | working_directory: ~/opensource-mono2 30 | docker: 31 | - image: fpco/stack-build:lts-8.20 32 | steps: 33 | - checkout 34 | - restore_cache: 35 | key: stack-cache-nightly 36 | - run: 37 | name: stack setup 38 | command: 'stack --resolver nightly setup' 39 | - run: 40 | name: stack install dependencies 41 | command: 'stack --resolver nightly build --test --only-dependencies' 42 | - save_cache: 43 | key: stack-cache-nightly 44 | paths: 45 | - ~/.stack 46 | - ~/opensource-mono2/.stack-work 47 | - run: 48 | name: stack build 49 | command: 'stack --resolver nightly build --fast --pedantic' 50 | - run: 51 | name: stack test 52 | command: 'stack --resolver nightly test --fast' 53 | 54 | workflows: 55 | version: 2 56 | build_and_test: 57 | jobs: 58 | - build 59 | - build-nightly 60 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | .HTF/ 3 | .DS_Store -------------------------------------------------------------------------------- /NAMES.md: -------------------------------------------------------------------------------- 1 | # List of Open Sourced modules 2 | 3 | - Cpm.Util.Alternative --> Control.Applicative.Plus 4 | - Cpm.Util.Choice -> Data.Choice 5 | - Cpm.Util.Fail -> Data.Fail 6 | - Cpm.Util.List -> Data.List.Plus 7 | - Cpm.Util.OSMap -> Data.Map.Ordered 8 | - Cpm.Util.Option -> Data.Option 9 | - Cpm.Util.Preview -> Data.Preview 10 | - Cpm.Util.Safe -> Safe.Plus 11 | - Cpm.Util.SourceLocation -> GHC.Stack.Plus 12 | - Cpm.Util.StrictList -> Data.StrictList 13 | - Cpm.Util.Text -> Data.Text.Plus 14 | - Cpm.Util.Tuple -> Data.StrictTuple 15 | - Cpm.Util.USMap -> Data.Map.Unordered 16 | - Cpm.Util.Vector -> Data.StrictVector 17 | - Cpm.Util.Vector.Mutable -> Data.StrictVector.Mutable 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Factis Research Open Source 2 | 3 | [![CircleCI](https://circleci.com/gh/factisresearch/opensource.svg?style=svg)](https://circleci.com/gh/factisresearch/opensource) 4 | 5 | Welcome to our collection of open source packages. All packages here are extracted from our production code for [Checkpad MED](https://www.checkpad.de/). 6 | -------------------------------------------------------------------------------- /graph-core/.gitignore: -------------------------------------------------------------------------------- 1 | ## HASKELL 2 | dist 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *~ 9 | .virtualenv 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | cabal.config 14 | .HTF/ 15 | .stack-work/ 16 | 17 | ## OS X 18 | .DS_Store 19 | .AppleDouble 20 | .LSOverride 21 | 22 | # Icon must end with two \r 23 | Icon 24 | 25 | 26 | # Thumbnails 27 | ._* 28 | 29 | # Files that might appear on external disk 30 | .Spotlight-V100 31 | .Trashes 32 | 33 | # Directories potentially created on remote AFP share 34 | .AppleDB 35 | .AppleDesktop 36 | Network Trash Folder 37 | Temporary Items 38 | -------------------------------------------------------------------------------- /graph-core/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 - 2016 factis research GmbH 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /graph-core/README.md: -------------------------------------------------------------------------------- 1 | graph-core 2 | ===== 3 | 4 | [![Build Status](https://travis-ci.org/factisresearch/graph-core.git.svg)](https://travis-ci.org/factisresearch/graph-core.git) 5 | [![Hackage](https://img.shields.io/hackage/v/graph-core.svg)](http://hackage.haskell.org/package/graph-core) 6 | 7 | ## Intro 8 | 9 | Hackage: [graph-core](http://hackage.haskell.org/package/graph-core) 10 | Stackage: [graph-core](https://www.stackage.org/package/graph-core) 11 | 12 | Fast, memory efficient and persistent graph implementation 13 | 14 | 15 | ## Install 16 | 17 | * Using cabal: `cabal install graph-core` 18 | * Using Stack: `stack install graph-core` 19 | * From Source (cabal): `git clone https://github.com/factisresearch/graph-core.git.git && cd graph-core.git && cabal install` 20 | * From Source (stack): `git clone https://github.com/factisresearch/graph-core.git.git && cd graph-core.git && stack build` 21 | 22 | 23 | ## Misc 24 | 25 | ### Supported GHC Versions 26 | 27 | 28 | ### License 29 | 30 | Released under the MIT license. 31 | (c) 2014 - 2016 factis research GmbH 32 | -------------------------------------------------------------------------------- /graph-core/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /graph-core/graph-core.cabal: -------------------------------------------------------------------------------- 1 | name: graph-core 2 | version: 0.3.0.0 3 | synopsis: Fast, memory efficient and persistent graph implementation 4 | description: A small package providing a powerful and easy to use Haskell graph implementation. 5 | homepage: https://github.com/factisresearch/opensource#readme 6 | license: MIT 7 | license-file: LICENSE 8 | author: Stefan Wehr , David Leuschner , Niklas Baumstark, Jonathan Dimond, Alexander Thiemann 9 | maintainer: Alexander Thiemann 10 | copyright: (c) 2014 - 2016 factis research GmbH 11 | category: Data 12 | build-type: Simple 13 | cabal-version: >=1.8 14 | 15 | library 16 | exposed-modules: Data.Core.Graph, Data.Core.Graph.NodeManager, Data.Core.Graph.Persistence 17 | other-modules: Data.Core.Graph.PureCore 18 | build-depends: base >=4.6 && <5, 19 | hashable >=1.2, 20 | unordered-containers >=0.2, 21 | containers >=0.5, 22 | safe >=0.3, 23 | deepseq >=1.3, 24 | vector >=0.10, 25 | mtl >=2.1 26 | hs-source-dirs: src 27 | ghc-options: -Wall 28 | 29 | test-suite graph-core-tests 30 | type: exitcode-stdio-1.0 31 | hs-source-dirs: src 32 | main-is: Tests.hs 33 | other-modules: Test.NodeManager, Test.Core, Test.Persistence, Test.Arbitrary 34 | build-depends: base >=4.6 && <5, 35 | hashable >=1.2, 36 | unordered-containers >=0.2, 37 | containers >=0.5, 38 | safe >=0.3, 39 | deepseq >=1.3, 40 | vector >=0.10, 41 | QuickCheck >=2.6, 42 | mtl >=2.1, 43 | HTF >=0.11 44 | ghc-options: -Wall -fno-warn-orphans 45 | 46 | source-repository head 47 | type: git 48 | location: https://github.com/factisresearch/opensource.git 49 | -------------------------------------------------------------------------------- /graph-core/src/Data/Core/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Data.Core.Graph 8 | ( Graph, Node, NodeSet, Edge(..) 9 | , empty, fromEdges, fromAdj, isConsistent 10 | , nodes, edges, children, parents, hasEdge 11 | , edgeCount 12 | , hull, rhull, hullFold, hullFoldM, rhullFold 13 | , addEdge, addEdges, removeEdge, removeEdges 14 | , addNode, removeNode, solitaireNodes 15 | , edgesAdj 16 | ) 17 | where 18 | 19 | import Data.Core.Graph.NodeManager hiding (isConsistent, nodes) 20 | import Data.Core.Graph.PureCore 21 | -------------------------------------------------------------------------------- /graph-core/src/Data/Core/Graph/NodeManager.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE CPP #-} 5 | module Data.Core.Graph.NodeManager 6 | ( NodeManager, Node, NodeMap, NodeSet 7 | , emptyNode 8 | , initNodeManager, emptyNodeManager, getNodeMap 9 | , getNodeHandle, getExistingNodeHandle, lookupNode, unsafeLookupNode 10 | , removeNodeHandle 11 | , getNewNodesSince, keys, hasKey, nodes, toList 12 | , isConsistent 13 | ) 14 | where 15 | 16 | import Control.Monad.State.Strict 17 | import Data.Hashable 18 | import Data.Maybe 19 | import qualified Data.HashMap.Strict as HM 20 | import qualified Data.IntMap.Strict as IM 21 | import qualified Data.IntSet as IS 22 | import qualified Data.List as L 23 | 24 | type Node = Int 25 | type NodeMap v = IM.IntMap v 26 | type NodeSet = IS.IntSet 27 | 28 | emptyNode :: Node 29 | emptyNode = -1 30 | 31 | data NodeManager k 32 | = NodeManager 33 | { nm_nodeToKey :: !(NodeMap k) 34 | , nm_keyToNode :: !(HM.HashMap k Node) 35 | , nm_nextNode :: !Node 36 | } deriving (Show, Eq) 37 | 38 | swap :: forall a b. (a, b) -> (b, a) 39 | swap (x,y) = (y,x) 40 | 41 | isConsistent :: (Ord k) => NodeManager k -> Bool 42 | isConsistent (NodeManager{..}) = 43 | IM.size nm_nodeToKey == HM.size nm_keyToNode 44 | && (IM.null nm_nodeToKey || (nm_nextNode > fst (IM.findMax nm_nodeToKey) 45 | && emptyNode < fst (IM.findMin nm_nodeToKey))) 46 | && L.sort (HM.toList nm_keyToNode) == L.sort (map swap (IM.toList nm_nodeToKey)) 47 | 48 | -- map must contain only non-negative keys! 49 | initNodeManager :: (Hashable k, Eq k) => NodeMap k -> NodeManager k 50 | initNodeManager nm = 51 | case IM.minViewWithKey nm of 52 | Just ((n, _), _) | n <= emptyNode -> error $ "Invalid node ID: " ++ show n 53 | _ -> NodeManager nm (invert nm) nextNode 54 | where nextNode 55 | | IM.null nm = 0 56 | | otherwise = 1 + fst (IM.findMax nm) 57 | invert im = HM.fromList . map swap $ IM.toList im 58 | 59 | getNodeMap :: (Hashable k, Eq k) => NodeManager k -> NodeMap k 60 | getNodeMap = nm_nodeToKey 61 | 62 | keys :: NodeManager k -> [k] 63 | keys nm = 64 | HM.keys (nm_keyToNode nm) 65 | 66 | hasKey :: (Eq k, Hashable k) => k -> NodeManager k -> Bool 67 | hasKey k nm = 68 | isJust $ HM.lookup k (nm_keyToNode nm) 69 | 70 | toList :: NodeManager k -> [(k, Node)] 71 | toList nm = HM.toList (nm_keyToNode nm) 72 | 73 | nodes :: NodeManager k -> [Node] 74 | nodes nm = IM.keys (nm_nodeToKey nm) 75 | 76 | getNewNodesSince :: Node -> NodeManager k -> NodeMap k 77 | getNewNodesSince n (NodeManager{..}) = snd $ IM.split n nm_nodeToKey 78 | 79 | emptyNodeManager :: forall k. NodeManager k 80 | emptyNodeManager = NodeManager IM.empty HM.empty 0 81 | 82 | getNodeHandle :: (Hashable k, Eq k, MonadState (NodeManager k) m) => k -> m Node 83 | getNodeHandle k = 84 | do NodeManager{..} <- get 85 | case HM.lookup k nm_keyToNode of 86 | Just i -> return i 87 | Nothing -> 88 | do let i = nm_nextNode 89 | put $! NodeManager { nm_nodeToKey = IM.insert i k nm_nodeToKey 90 | , nm_keyToNode = HM.insert k i nm_keyToNode 91 | , nm_nextNode = i + 1 92 | } 93 | return i 94 | 95 | removeNodeHandle :: (Hashable k, Eq k) => Node -> NodeManager k -> NodeManager k 96 | removeNodeHandle i nm@(NodeManager{..}) = 97 | case IM.lookup i nm_nodeToKey of 98 | Just k -> 99 | nm { nm_nodeToKey = IM.delete i nm_nodeToKey 100 | , nm_keyToNode = HM.delete k nm_keyToNode 101 | } 102 | Nothing -> nm 103 | 104 | getExistingNodeHandle :: (Hashable k, Eq k) => k -> NodeManager k -> Maybe Node 105 | getExistingNodeHandle k (NodeManager{..}) = HM.lookup k nm_keyToNode 106 | 107 | lookupNode :: Node -> NodeManager k -> Maybe k 108 | lookupNode i (NodeManager{..}) = IM.lookup i nm_nodeToKey 109 | 110 | unsafeLookupNode :: Node -> NodeManager k -> k 111 | unsafeLookupNode i nm = fromJust $ lookupNode i nm 112 | -------------------------------------------------------------------------------- /graph-core/src/Data/Core/Graph/Persistence.hs: -------------------------------------------------------------------------------- 1 | module Data.Core.Graph.Persistence 2 | ( PersistentGraph, persistGraph, loadGraph ) 3 | where 4 | 5 | import Data.Core.Graph.PureCore 6 | import Data.Core.Graph.NodeManager 7 | 8 | import Data.Hashable 9 | import qualified Data.IntMap.Strict as IM 10 | import qualified Data.Vector.Unboxed as VU 11 | 12 | data PersistentGraph k 13 | = PersistentGraph 14 | { pg_nodeData :: NodeMap k 15 | , pg_graphData :: [(Node, [Node])] 16 | } deriving (Show, Eq) 17 | 18 | persistGraph :: (Eq k, Hashable k) => NodeManager k -> Graph -> PersistentGraph k 19 | persistGraph nodeManager graph = 20 | PersistentGraph 21 | { pg_nodeData = getNodeMap nodeManager 22 | , pg_graphData = map (\(k, vals) -> (k, VU.toList vals)) (IM.toList $ g_adj graph) 23 | } 24 | 25 | loadGraph :: (Eq k, Hashable k) => PersistentGraph k -> (NodeManager k, Graph) 26 | loadGraph (PersistentGraph nodeData graphData) = 27 | (initNodeManager nodeData, fromAdj graphData) -------------------------------------------------------------------------------- /graph-core/src/Data/Core/Graph/PureCore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Data.Core.Graph.PureCore where 8 | 9 | import Data.Core.Graph.NodeManager hiding (nodes, isConsistent) 10 | 11 | import Control.Applicative hiding (empty) 12 | import Control.Arrow 13 | import Control.DeepSeq 14 | import Control.Monad 15 | import Control.Monad.Identity 16 | import Control.Monad.ST 17 | import Data.Function (on) 18 | import Data.Hashable 19 | import Data.Maybe 20 | import Data.STRef 21 | import qualified Data.Foldable as F 22 | import qualified Data.HashSet as HS 23 | import qualified Data.IntMap.Strict as IM 24 | import qualified Data.IntSet as IS 25 | import qualified Data.List as L 26 | import qualified Data.Vector.Unboxed as VU 27 | 28 | type AdjList = NodeMap (VU.Vector Node) 29 | data Edge = Edge { src :: !Node, tgt :: !Node } deriving (Show, Eq, Ord) 30 | 31 | instance Hashable Edge where 32 | hashWithSalt s (Edge x y) = s `hashWithSalt` x `hashWithSalt` y 33 | 34 | data Graph 35 | = Graph 36 | { g_adj :: !AdjList 37 | , g_radj :: !AdjList 38 | } 39 | 40 | empty :: Graph 41 | empty = Graph IM.empty IM.empty 42 | 43 | invert :: Edge -> Edge 44 | invert (Edge x y) = Edge y x 45 | 46 | instance Show Graph where 47 | show g = "< " ++ L.intercalate ",\n " (map showNode (nodes g)) ++ " >" 48 | where showNode x = show x 49 | ++ " -> [" 50 | ++ L.intercalate "," (map show (VU.toList (children g x))) 51 | ++ "]" 52 | 53 | instance Eq Graph where 54 | a == b = sameItems (nodes a) (nodes b) 55 | && all (\x -> sameItems (VU.toList (children a x)) (VU.toList (children b x))) 56 | (nodes a) 57 | where sameItems x y = IS.fromList x == IS.fromList y 58 | 59 | instance NFData Graph where 60 | rnf (Graph a b) = rnf a `seq` rnf b 61 | 62 | adjToEdges :: [(Node, [Node])] -> [Edge] 63 | adjToEdges = concatMap (\(x, ys) -> map (Edge x) ys) 64 | 65 | edgesAdj :: AdjList -> [Edge] 66 | edgesAdj adj = adjToEdges . map (second VU.toList) $ IM.toList adj 67 | 68 | isConsistent :: Graph -> Bool 69 | isConsistent (Graph{..}) = L.sort forwardEdges == L.sort (map invert (edgesAdj g_radj)) 70 | && HS.size (HS.fromList forwardEdges) == length forwardEdges 71 | where forwardEdges = edgesAdj g_adj 72 | 73 | fromEdges :: [Edge] -> Graph 74 | fromEdges edgeList = 75 | Graph { g_adj = mkAdj edgeList 76 | , g_radj = mkAdj $ map invert edgeList 77 | } 78 | where 79 | mkAdj e = IM.fromList $ map (src . head &&& VU.fromList . map tgt) 80 | . L.groupBy ((==) `on` src) 81 | . L.sortBy (compare `on` src) $ e 82 | 83 | fromAdj :: [(Node, [Node])] -> Graph 84 | fromAdj l = 85 | let g1 = fromEdges (adjToEdges l) 86 | solitaires = map fst $ filter (\(_, xs) -> null xs) l 87 | in L.foldl' (\g n -> g { g_adj = IM.insert n VU.empty (g_adj g) }) g1 solitaires 88 | 89 | nodes :: Graph -> [Node] 90 | nodes g = IM.keys (IM.union (g_adj g) (g_radj g)) 91 | 92 | edges :: Graph -> [Edge] 93 | edges = edgesAdj . g_adj 94 | 95 | solitaireNodes :: Graph -> [Node] 96 | solitaireNodes g = IM.keys (IM.filter VU.null (IM.union (g_adj g) (g_radj g))) 97 | 98 | edgeCount :: Graph -> Int 99 | edgeCount = F.foldl' (\old (_,adj) -> old + VU.length adj) 0 100 | . IM.toList . g_adj 101 | 102 | children :: Graph -> Node -> VU.Vector Node 103 | children g x = neighbors g (g_adj g) x 104 | 105 | parents :: Graph -> Node -> VU.Vector Node 106 | parents g x = neighbors g (g_radj g) x 107 | 108 | neighbors :: Graph -> AdjList -> Node -> VU.Vector Node 109 | neighbors (Graph{..}) adj x = IM.findWithDefault VU.empty x adj 110 | 111 | hasEdge :: Node -> Node -> Graph -> Bool 112 | hasEdge x y (Graph{..}) = y `VU.elem` IM.findWithDefault VU.empty x g_adj 113 | 114 | addNode :: Node -> Graph -> Graph 115 | addNode x g = 116 | g { g_adj = IM.insertWith (\_new old -> old) x VU.empty (g_adj g) } 117 | 118 | removeNode :: Node -> Graph -> Graph 119 | removeNode x g = 120 | let rmInAdj adj localF = 121 | foldl (\adjList child -> 122 | IM.adjust (VU.filter (/=x)) child adjList 123 | ) (IM.delete x adj) $ VU.toList (localF g x) 124 | 125 | newAdj = rmInAdj (g_adj g) parents 126 | newRAdj = rmInAdj (g_radj g) children 127 | in g { g_adj = newAdj 128 | , g_radj = newRAdj 129 | } 130 | 131 | addEdge :: Node -> Node -> Graph -> Graph 132 | addEdge x y g@(Graph{..}) = 133 | if hasEdge x y g 134 | then g 135 | else Graph { g_adj = alterDef VU.empty (flip VU.snoc y) x g_adj 136 | , g_radj = alterDef VU.empty (flip VU.snoc x) y g_radj 137 | } 138 | where alterDef def f = IM.alter (Just . f . fromMaybe def) 139 | 140 | addEdges :: [Edge] -> Graph -> Graph 141 | addEdges edgeList g = L.foldl' (flip (\(Edge x y) -> addEdge x y)) g edgeList 142 | 143 | removeEdge :: Node -> Node -> Graph -> Graph 144 | removeEdge x y (Graph{..}) = 145 | Graph { g_adj = IM.adjust (VU.filter (/=y)) x g_adj 146 | , g_radj = IM.adjust (VU.filter (/=x)) y g_radj 147 | } 148 | 149 | removeEdges :: [Edge] -> Graph -> Graph 150 | removeEdges edgeList g = L.foldl' (flip (\(Edge x y) -> removeEdge x y)) g edgeList 151 | 152 | hull :: Graph -> Node -> NodeSet 153 | hull g = hullImpl g (g_adj g) 154 | 155 | rhull :: Graph -> Node -> NodeSet 156 | rhull g = hullImpl g (g_radj g) 157 | 158 | hullImpl :: Graph -> AdjList -> Node -> NodeSet 159 | hullImpl (Graph{..}) adj root = 160 | runST $ 161 | do vis <- newSTRef IS.empty 162 | let go x = 163 | (IS.member x <$> readSTRef vis) >>= 164 | (flip unless $ 165 | do modifySTRef' vis (IS.insert x) 166 | VU.forM_ (IM.findWithDefault VU.empty x adj) go) 167 | go root 168 | readSTRef vis 169 | 170 | rhullFold :: Graph -> (b -> Node -> b) -> b -> Node -> b 171 | rhullFold g f initial node = 172 | runIdentity $ hullFoldImpl (g_radj g) (\x y -> return (f x y)) initial node 173 | 174 | -- FIXME: benchmark against old hullFold implementation 175 | hullFold :: Graph -> (b -> Node -> b) -> b -> Node -> b 176 | hullFold g f initial node = 177 | runIdentity $ hullFoldImpl (g_adj g) (\x y -> return (f x y)) initial node 178 | 179 | hullFoldM :: Monad m => Graph -> (b -> Node -> m b) -> b -> Node -> m b 180 | hullFoldM g = hullFoldImpl (g_adj g) 181 | 182 | hullFoldImpl :: Monad m => AdjList -> (b -> Node -> m b) -> b -> Node -> m b 183 | hullFoldImpl adj f initial root = 184 | go IS.empty initial [root] 185 | where 186 | go _ acc [] = return acc 187 | go !visited !acc (x:xs) = 188 | if (IS.member x visited) 189 | then go visited acc xs 190 | else do newAcc <- f acc x 191 | let succs = IM.findWithDefault VU.empty x adj 192 | go (IS.insert x visited) newAcc (xs ++ VU.toList succs) 193 | -------------------------------------------------------------------------------- /graph-core/src/Test/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | module Test.Arbitrary where 2 | 3 | import Test.QuickCheck 4 | import Control.Monad (forM) 5 | import Data.Core.Graph.NodeManager (NodeMap) 6 | import Data.Core.Graph.PureCore (Graph, empty, fromAdj) 7 | import qualified Data.IntMap.Strict as IM 8 | 9 | 10 | newtype TestNodeMap v = TestNodeMap(NodeMap v) deriving Show 11 | 12 | instance Arbitrary v => Arbitrary (TestNodeMap v) where 13 | arbitrary = fmap (TestNodeMap . IM.fromList . map (\(NonNegative i, x) -> (i, x))) arbitrary 14 | 15 | instance Arbitrary Graph where 16 | arbitrary = frequency [(1, return empty), (20, denseGraph)] 17 | where denseGraph = 18 | do n <- choose (0, 30::Int) 19 | let nodeList = [1..n] 20 | adj <- forM nodeList $ \i -> 21 | do bits <- vectorOf n arbitrary 22 | return (i, [ x | (x,b) <- zip nodeList bits, b ]) 23 | return $ fromAdj adj 24 | -------------------------------------------------------------------------------- /graph-core/src/Test/Core.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Test.Core where 3 | 4 | import Data.Core.Graph.PureCore 5 | import Data.Core.Graph.NodeManager (Node) 6 | 7 | import Control.Monad 8 | import Test.Arbitrary () 9 | import Test.Framework 10 | import qualified Data.IntSet as IS 11 | 12 | e :: (Node, Node) -> Edge 13 | e (x,y) = Edge x y 14 | 15 | testGraphA :: Graph 16 | testGraphA = fromAdj [(1, [2,3]), (2, [3,4]), (3, [4])] 17 | 18 | testGraphB :: Graph 19 | testGraphB = fromEdges [e (1,2), e (2,1)] 20 | 21 | test_hasEdge :: IO () 22 | test_hasEdge = 23 | do assertEqual True $ hasEdge 2 4 testGraphA 24 | forM_ (edges testGraphA) $ \(Edge a b) -> 25 | assertEqual True (hasEdge a b testGraphA) 26 | assertEqual False $ hasEdge 1 4 testGraphA 27 | assertEqual False $ hasEdge 1000 200 testGraphA 28 | 29 | test_removeEdges :: IO () 30 | test_removeEdges = 31 | do assertEqual (fromAdj [(1, [2]), (2, [3,4]), (3, [4]), (4, [])]) 32 | (removeEdges [e (1,3), e (4,1)] testGraphA) 33 | 34 | test_removeNode :: IO () 35 | test_removeNode = 36 | let orig = fromAdj [(1, [2]), (2, [3,4]), (3, [4]), (4, [])] 37 | res1 = fromAdj [(1, [2]), (2, [3]), (3, [])] 38 | res2 = fromAdj [(1, [2]), (2, [4]), (4, [])] 39 | res3 = fromAdj [(1, []), (3, [4]), (4, [])] 40 | 41 | in do assertEqual res1 (removeNode 4 orig) 42 | assertEqual res2 (removeNode 3 orig) 43 | assertEqual res3 (removeNode 2 orig) 44 | assertEqual orig (removeNode 5 orig) 45 | 46 | test_hull :: IO () 47 | test_hull = 48 | do assertEqual (IS.fromList [4]) (hull testGraphA 4) 49 | assertEqual (IS.fromList [1,2,3,4]) (hull testGraphA 1) 50 | assertEqual (IS.fromList [2,3,4]) (hull testGraphA 2) 51 | assertEqual (IS.fromList [3,4]) (hull testGraphA 3) 52 | assertEqual (IS.fromList [100]) (hull testGraphA 100) 53 | assertEqual (IS.fromList [1,2]) (hull testGraphB 1) 54 | 55 | test_rhull :: IO () 56 | test_rhull = 57 | do assertEqual (IS.fromList [1,2,3]) (rhull testGraphA 3) 58 | assertEqual (IS.fromList [1]) (rhull testGraphA 1) 59 | assertEqual (IS.fromList [1,2]) (rhull testGraphB 1) 60 | 61 | test_hullFold :: IO () 62 | test_hullFold = 63 | do assertEqual 10 (hullFold testGraphA (+) 0 1) 64 | assertEqual 4 (hullFold testGraphA (+) 0 4) 65 | assertEqual 100 (hullFold testGraphA (+) 0 100) 66 | assertEqual 3 (hullFold testGraphB (+) 0 1) 67 | 68 | prop_fromEdgesAddEdges :: Graph -> Bool 69 | prop_fromEdgesAddEdges g = 70 | let isCons = isConsistent new 71 | isEq = new == g 72 | in if isCons && isEq 73 | then True 74 | else error ("g=" ++ show g ++ ", new=" ++ show new ++ 75 | ", isCons=" ++ show isCons ++ ", isEq=" ++ show isEq) 76 | where 77 | new = 78 | foldl (\g' n -> addNode n g') (addEdges (edges g) empty) (solitaireNodes g) 79 | 80 | prop_fromEdgesToEdges :: Graph -> Bool 81 | prop_fromEdgesToEdges g = isConsistent new && new == g 82 | where 83 | new = 84 | foldl (\g' n -> addNode n g') (fromEdges (edges g)) (solitaireNodes g) 85 | -------------------------------------------------------------------------------- /graph-core/src/Test/NodeManager.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Test.NodeManager where 3 | 4 | import Data.Core.Graph.NodeManager 5 | 6 | import Test.Arbitrary 7 | import Test.Framework 8 | import Control.Monad.State.Strict 9 | import qualified Data.IntMap.Strict as IM 10 | import qualified Data.List as L 11 | 12 | assertConsistent :: StateT (NodeManager Char) IO () 13 | assertConsistent = get >>= liftIO . assertEqual True . isConsistent 14 | 15 | prop_init :: TestNodeMap String -> Property 16 | prop_init (TestNodeMap m) = uniqueValues m && all (>=0) (IM.keys m) 17 | ==> isConsistent new && m == getNodeMap new 18 | where new = initNodeManager m 19 | uniqueValues im = IM.size im == length (L.nub $ IM.elems im) 20 | 21 | test_getNewNodesSince :: IO () 22 | test_getNewNodesSince = 23 | flip evalStateT emptyNodeManager $ 24 | do _ <- getNodeHandle 'a' 25 | n2 <- getNodeHandle 'b' 26 | n3 <- getNodeHandle 'c' 27 | n4 <- getNodeHandle 'd' 28 | new <- gets (getNewNodesSince n2) 29 | liftIO $ assertEqual (IM.fromList [(n3, 'c'), (n4, 'd')]) new 30 | 31 | test_getNodeHandle :: IO () 32 | test_getNodeHandle = 33 | flip evalStateT emptyNodeManager $ 34 | do n1 <- getNodeHandle 'a' 35 | n2 <- getNodeHandle 'a' 36 | liftIO $ assertEqual n1 n2 37 | n3 <- getNodeHandle 'b' 38 | n4 <- getNodeHandle 'b' 39 | liftIO $ assertEqual n3 n4 40 | n5 <- getNodeHandle 'a' 41 | liftIO $ assertEqual n1 n5 42 | liftIO $ assertNotEqual n1 n3 43 | assertConsistent 44 | 45 | test_lookupNode :: IO () 46 | test_lookupNode = 47 | flip evalStateT emptyNodeManager $ 48 | do n1 <- getNodeHandle 'a' 49 | n2 <- getNodeHandle 'b' 50 | x1 <- gets $ lookupNode n1 51 | x2 <- gets $ lookupNode n2 52 | x3 <- gets $ lookupNode 123 53 | liftIO $ assertEqual (Just 'a') x1 54 | liftIO $ assertEqual (Just 'b') x2 55 | liftIO $ assertEqual Nothing x3 56 | assertConsistent 57 | -------------------------------------------------------------------------------- /graph-core/src/Test/Persistence.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Test.Persistence where 3 | 4 | import Data.Core.Graph 5 | import Data.Core.Graph.NodeManager 6 | import Data.Core.Graph.Persistence 7 | 8 | import Test.Arbitrary 9 | import Test.Framework 10 | 11 | prop_persistence :: TestNodeMap Char -> Graph -> Bool 12 | prop_persistence (TestNodeMap nodeMap) graph = 13 | let nodeMgr = initNodeManager nodeMap 14 | (nodeMgr', graph') = loadGraph (persistGraph nodeMgr graph) 15 | in (nodeMgr' == nodeMgr && graph == graph') 16 | -------------------------------------------------------------------------------- /graph-core/src/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Main where 3 | 4 | import Test.Framework 5 | import {-@ HTF_TESTS @-} Test.Core 6 | import {-@ HTF_TESTS @-} Test.NodeManager 7 | import {-@ HTF_TESTS @-} Test.Persistence 8 | 9 | main :: IO () 10 | main = htfMain htf_importedTests 11 | -------------------------------------------------------------------------------- /helper.hs: -------------------------------------------------------------------------------- 1 | -- Run this using 2 | -- @stack exec -- runhaskell helper.hs@ 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | import System.Directory 6 | import System.Environment 7 | import System.FilePath 8 | import qualified Data.Text as T 9 | import qualified Data.Text.IO as T 10 | 11 | main :: IO () 12 | main = 13 | do args <- getArgs 14 | case args of 15 | ["opensource", file, package, newName] -> 16 | do ct <- T.readFile file 17 | let fileName = 18 | package ++ "/src/" 19 | ++ T.unpack (T.replace "." "/" (T.pack newName)) 20 | ++ ".hs" 21 | baseDir = takeDirectory fileName 22 | createDirectoryIfMissing True baseDir 23 | T.writeFile fileName ct 24 | _ -> 25 | putStrLn "Usage: helper.hs opensource [src] [pkg] [tgt]" 26 | -------------------------------------------------------------------------------- /preview/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright factis research GmbH (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Kierán Meinhardt nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /preview/README.md: -------------------------------------------------------------------------------- 1 | # preview 2 | -------------------------------------------------------------------------------- /preview/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /preview/preview.cabal: -------------------------------------------------------------------------------- 1 | name: preview 2 | version: 0.1.0.4 3 | synopsis: The method of previewing data (instead of wholly show-ing it) 4 | description: The method of previewing data (instead of wholly show-ing it) 5 | homepage: https://github.com/factisresearch/opensource#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: factis research GmbH 9 | maintainer: kieran.meinhardt@gmail.com 10 | copyright: 2017 factis research GmbH 11 | category: Data 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Data.Preview 19 | build-depends: base >= 4.7 && < 5 20 | , containers 21 | , pretty 22 | , strict-data 23 | , text 24 | , util-plus 25 | default-language: Haskell2010 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/factisresearch/opensource.git 30 | -------------------------------------------------------------------------------- /preview/src/Data/Preview.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | module Data.Preview 5 | (Preview(..), preview, previewNamedSet, previewNamedList, previewList 6 | ,previews, previewRec ,previewRec', previewKv, showKv 7 | ,previewElems, previewsElems, pprMapping, previewList', previewsPrecMapping 8 | ,Ppr(..), Ppr'(..), Doc, pretty, prettyText, docFromStr, shortPreviewStr 9 | ,docFromText,angles 10 | ) 11 | where 12 | 13 | import Data.Bifunctor 14 | import Data.Choice (Choice(..), mergeChoice) 15 | import Data.Fail (Fail(..)) 16 | import Data.List.Plus 17 | import Data.Option (Option(..)) 18 | import Data.StrictList (StrictList, toLazyList) 19 | import Data.StrictTuple (Pair(..)) 20 | import qualified Data.Map.Ordered as OM 21 | import qualified Data.Map.Unordered as UM 22 | 23 | import Data.Int (Int32, Int64) 24 | import Data.Map (Map) 25 | import Data.Maybe (fromMaybe) 26 | import Data.Set (Set) 27 | import Data.Word (Word8, Word64) 28 | import Text.PrettyPrint.HughesPJ (Doc, (<>), (<+>)) 29 | import qualified Data.Foldable as F 30 | import qualified Data.Map as Map 31 | import qualified Data.Set as Set 32 | import qualified Data.Text as T 33 | import qualified Text.PrettyPrint.HughesPJ as P 34 | 35 | _LIST_PREVIEW_ELEMS_ :: Int 36 | _LIST_PREVIEW_ELEMS_ = 10 37 | 38 | -- | Conversion of values to short readable strings. 39 | -- Preview allows defining short and readable representations of potentially huge data structures 40 | -- that can be used in logs for example. E.g. the Preview instance for lists may only print the 41 | -- values at the beginning of the list and omit the rest. 42 | class Preview a where 43 | -- | Create a preview String for the given value. 44 | -- 45 | -- 'previewsPrec' should satisfy the law 46 | -- 47 | -- > previewsPrec d x r ++ s == previewsPrec d x (r ++ s) 48 | previewsPrec 49 | :: Int 50 | -- ^ The operator precedence of the enclosing context (a number from 0 to 11). Function 51 | -- application has precedence 10. 52 | -> a -- ^ the value to be previewed 53 | -> String -- ^ the string to be appended at the end of the output (for constant time append) 54 | -> String 55 | 56 | instance Preview () where previewsPrec = showsPrec 57 | instance Preview Char where previewsPrec = showsPrec 58 | instance Preview Int where previewsPrec = showsPrec 59 | instance Preview Bool where previewsPrec = showsPrec 60 | instance Preview a => Preview [a] where previewsPrec = previewList 61 | instance Preview T.Text where previewsPrec = previewsText 62 | 63 | instance Ppr T.Text where 64 | ppr = P.text . T.unpack 65 | 66 | instance (Preview a, Preview b) => Preview (Either a b) where 67 | previewsPrec prec eAB s = 68 | case eAB of 69 | Left a -> previewsPrec prec a s 70 | Right b -> previewsPrec prec b s 71 | 72 | instance (Preview a) => Preview (Maybe a) where 73 | previewsPrec prec mA s = 74 | case mA of 75 | Nothing -> showString "Nothing" s 76 | Just a -> previewsPrec prec a s 77 | 78 | instance (Preview a, Preview b) => Preview (a, b) where 79 | previewsPrec prec (a, b) = 80 | showParen (prec >= 10) $ 81 | previewsPrec 5 a . 82 | showString ", " . 83 | previewsPrec 5 b 84 | 85 | instance (Preview a, Preview b, Preview c) => Preview (a, b, c) where 86 | previewsPrec prec (a, b, c) = 87 | showString "(" . 88 | previewsPrec prec a . 89 | showString ", " . 90 | previewsPrec prec b . 91 | showString ", " . 92 | previewsPrec prec c . 93 | showString ")" 94 | 95 | instance Preview Word8 where 96 | previewsPrec = showsPrec 97 | 98 | instance Preview Word64 where 99 | previewsPrec = showsPrec 100 | 101 | instance Preview Int32 where 102 | previewsPrec = showsPrec 103 | 104 | instance Preview Int64 where 105 | previewsPrec = showsPrec 106 | 107 | instance (Preview k, Preview v) => Preview (Map k v) where 108 | previewsPrec p = previewsPrecMapping p . Map.toList 109 | 110 | instance Preview a => Preview (Fail a) where 111 | previewsPrec p x = 112 | case x of 113 | Err msg -> showParen (p > 10) $ showString "Fail " . showsPrec 5 msg 114 | Ok a -> previewsPrec p a 115 | 116 | instance (Preview a, Preview b) => Preview (Pair a b) where 117 | previewsPrec p (x :!: y) = previewsPrec p (x, y) 118 | 119 | instance (Ppr a, Ppr b) => Ppr (Pair a b) where 120 | ppr (a :!: b) = P.parens ((ppr a <> P.semi) P.<+> ppr b) 121 | 122 | instance Preview a => Preview (Option a) where 123 | previewsPrec prec mA s = 124 | case mA of 125 | None -> showsPrec prec ("None"::String) s 126 | Some a -> previewsPrec prec a s 127 | 128 | instance Preview a => Preview (StrictList a) where 129 | previewsPrec x y = previewList x (toLazyList y) 130 | 131 | instance Ppr a => Ppr (StrictList a) where 132 | ppr = pprMany 133 | 134 | instance Ppr a => Ppr (Option a) where 135 | ppr None = P.text "None" 136 | ppr (Some a) = ppr a 137 | 138 | instance (Preview a, Preview b) => Preview (Choice a b) where 139 | previewsPrec p choice = 140 | case choice of 141 | This a -> previewsPrec p a 142 | That b -> previewsPrec p b 143 | 144 | instance (Preview k, Preview v) => Preview (OM.OSMap k v) where 145 | previewsPrec p x = previewsPrec p (OM.toDataMap x) 146 | 147 | previewsPrecMapping :: (Preview k, Preview v) => t -> [(k, v)] -> String -> String 148 | previewsPrecMapping _ = 149 | (showString "{ " .) . 150 | foldr (.) (showString "}") . 151 | intersperse (showString "\n, ") . 152 | map (\(k,xs) -> previewsPrec 10 k . showString " -> " . previewsPrec 10 xs) . 153 | take _LIST_PREVIEW_ELEMS_ 154 | 155 | class Ppr a where 156 | ppr :: a -> Doc 157 | pprMany :: Foldable f => f a -> Doc 158 | pprMany xs = P.brackets (P.sep $ P.punctuate P.comma $ fmap ppr (F.toList xs)) 159 | 160 | class Ppr' k where 161 | ppr' :: Ppr a => k a -> Doc 162 | 163 | instance Ppr () where 164 | ppr () = P.text "()" 165 | 166 | instance Ppr Int64 where 167 | ppr i = P.text (show i) 168 | 169 | instance Ppr Char where 170 | ppr = P.char 171 | pprMany xs = P.char '"' <> F.foldl' (\d x -> d <> ppr x) P.empty xs <> P.char '"' 172 | 173 | instance Ppr Bool where 174 | ppr x = if x then P.text "True" else P.text "False" 175 | 176 | instance Ppr a => Ppr [a] where 177 | ppr = pprMany 178 | 179 | instance Ppr a => Ppr (Set a) where 180 | ppr = pprMany 181 | 182 | instance (Ppr a, Ppr b) => Ppr (Map a b) where 183 | ppr = pprMapping . Map.toList 184 | 185 | instance Ppr Doc where 186 | ppr = id 187 | 188 | instance Ppr a => Ppr (Fail a) where 189 | ppr (Ok x) = "Ok" <+> ppr x 190 | ppr (Err msg) = "Fail" <+> docFromStr (show msg) 191 | 192 | pprMapping :: (Ppr a, Ppr b) => [(a, b)] -> Doc 193 | pprMapping xs = 194 | P.braces (P.sep $ P.punctuate P.comma $ fmap pprTuple xs) 195 | where 196 | pprTuple (a, b) = P.sep [ppr a <+> P.text "->", P.nest 4 $ ppr b] 197 | 198 | instance (Ppr a, Ppr b) => Ppr (a, b) where 199 | ppr (a, b) = P.parens (ppr a <> P.comma <+> ppr b) 200 | 201 | instance Ppr Int where 202 | ppr = docFromStr . show 203 | 204 | instance Ppr Integer where 205 | ppr = docFromStr . show 206 | 207 | instance Ppr Int32 where 208 | ppr = docFromStr . show 209 | 210 | instance Ppr Word8 where 211 | ppr = docFromStr . show 212 | 213 | instance Ppr Double where 214 | ppr = docFromStr . show 215 | 216 | instance Ppr a => Ppr (Maybe a) where 217 | ppr (Just x) = ppr x 218 | ppr Nothing = P.text "Nothing" 219 | 220 | instance Ppr Word64 where 221 | ppr = docFromStr . show 222 | 223 | instance (Ppr k, Ppr v) => Ppr (OM.OSMap k v) where 224 | ppr = pprMapping . OM.toList 225 | 226 | instance (Ppr k, Ppr v) => Ppr (UM.USMap k v) where 227 | ppr = pprMapping . UM.toList 228 | 229 | instance (Ppr a, Ppr b) => Ppr (Choice a b) where 230 | ppr = mergeChoice . bimap ppr ppr 231 | 232 | pretty :: Ppr a => a -> String 233 | pretty = P.renderStyle (P.style { P.mode = P.LeftMode }) . ppr 234 | 235 | prettyText :: Ppr a => a -> T.Text 236 | prettyText = T.pack . pretty 237 | 238 | docFromStr :: String -> Doc 239 | docFromStr = P.text 240 | 241 | docFromText :: T.Text -> Doc 242 | docFromText = P.text . T.unpack 243 | 244 | preview :: Preview a => a -> String 245 | preview x = previewsPrec 5 x "" 246 | 247 | previews :: Preview a => a -> String -> String 248 | previews = previewsPrec 0 249 | 250 | previewRec :: Int -> String -> [(String, Int -> String -> String)] -> String -> String 251 | previewRec prec tyName fields = 252 | previewRec' prec tyName (map mapField fields) 253 | where 254 | mapField (n,f) = showString n . showString "=" . f 11 255 | 256 | previewRec' :: Int -> String -> [String -> String] -> String -> String 257 | previewRec' prec tyName fields = 258 | showParen (prec > 10) $ 259 | showString tyName . 260 | showString " { " . 261 | foldl' (.) id (intersperse (showString ", ") fields) . 262 | showString " }" 263 | 264 | previewKv :: Preview a => String -> a -> String -> String 265 | previewKv name x = 266 | showString name . showString "=" . (previewsPrec 5 x) 267 | 268 | showKv :: Show a => String -> a -> String -> String 269 | showKv name x = 270 | showString name . showString "=" . (showsPrec 5 x) 271 | 272 | previewNamedSet :: String -> t -> Set a -> String -> String 273 | previewNamedSet name _prec set = 274 | showString "|" . showString name . showString "|=" . showString (show (Set.size set)) 275 | 276 | previewNamedList :: String -> t -> [a] -> String -> String 277 | previewNamedList name _prec xs = 278 | showString "|" . showString name . showString "|=" . showString (show (length xs)) 279 | 280 | previewList' :: Preview a => Maybe Int -> Int -> [a] -> String -> String 281 | previewList' maxElems _prec xs = 282 | case xs of 283 | [] -> showString "[]" 284 | (x:rest) 285 | | maxElems == Nothing || length xs <= fromMaybe 0 maxElems -> 286 | showString "[" . 287 | foldl' (.) id (intersperse (showString ", ") (map (previewsPrec 11) xs)) . 288 | showString "]" 289 | | otherwise -> 290 | showString "[" . 291 | previewsPrec 5 x . 292 | if null rest 293 | then showString "]" 294 | else showString "... " . 295 | showsPrec 5 (length rest) . 296 | showString " more elems)]" 297 | 298 | previewList :: Preview a => Int -> [a] -> String -> String 299 | previewList = previewList' (Just _LIST_PREVIEW_ELEMS_) 300 | 301 | previewsElems :: (Foldable f, Preview a) => Int -> f a -> String -> String 302 | previewsElems _prec xs = 303 | showString "[" . 304 | foldl' (.) id (intersperse (showString ", ") (map (previewsPrec 5) (F.toList xs))) . 305 | showString "]" 306 | 307 | previewElems :: (Foldable t, Preview a) => t a -> String 308 | previewElems xs = previewsElems 5 xs "" 309 | 310 | previewsText :: Int -> T.Text -> ShowS 311 | previewsText _ t 312 | | T.length t < 65 = showString (T.unpack t) 313 | | otherwise = showString (T.unpack (T.take 65 t)) . showString "..." 314 | 315 | shortPreviewStr :: Int -> String -> String 316 | shortPreviewStr n s = 317 | if length s <= n 318 | then s 319 | else take n s ++ "..." 320 | 321 | angles :: Doc -> Doc 322 | angles p = P.char '<' <> p <> P.char '>' 323 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | packages: 3 | - preview 4 | - strict-data 5 | - text-plus 6 | - util-plus 7 | -------------------------------------------------------------------------------- /strict-data/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/factisresearch/opensource/d8b1fdf39d945bfcbc045ca9f73ab5aa84f89fa0/strict-data/.DS_Store -------------------------------------------------------------------------------- /strict-data/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Alexander Thiemann (c) 2016 2 | Copyright factis research GmbH (c) 2017 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of Alexander Thiemann nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /strict-data/README.md: -------------------------------------------------------------------------------- 1 | # Various strict data structures 2 | 3 | [![CircleCI](https://circleci.com/gh/factisresearch/opensource-mono.svg?style=svg)](https://circleci.com/gh/factisresearch/opensource-mono) 4 | 5 | This package currently contains strict data structures and useful instances for: 6 | 7 | * `Data.Choice` to replace `Data.Either` 8 | * `Data.Fail` for a sane error monad 9 | * `Data.Option` to replace `Data.Maybe` 10 | * `Data.StrictList` to replace `Data.List` 11 | * `Data.StrictTuple` to replace tuples 12 | * `Data.StrictVector` and `Data.StrictVector.Mutable` to replace `Data.Vector` 13 | and `Data.Vector.Mutable` 14 | -------------------------------------------------------------------------------- /strict-data/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /strict-data/src/Data/Choice.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Data.Choice where 3 | 4 | import Control.DeepSeq (NFData(..)) 5 | import Data.Bifunctor 6 | import Data.Data 7 | import Data.Hashable 8 | import Safe.Plus 9 | import Test.QuickCheck 10 | 11 | -- | 'Choice' is a version of 'Either' that is strict on both the 'Left' side (called 'This') 12 | -- and the 'Right' side (called 'That'). 13 | -- 14 | -- Note: 'Choice' is not used as an error monad. Use 'Data.Fail.Fail' for that. 15 | data Choice a b 16 | = This !a 17 | | That !b 18 | deriving (Eq, Ord, Read, Show, Typeable, Data) 19 | 20 | -- | 'Choice''s version of 'either' 21 | choice :: (a -> c) -> (b -> c) -> Choice a b -> c 22 | choice fa fb = mergeChoice . bimap fa fb 23 | 24 | -- | 25 | -- >>> this (This "foo") :: Maybe String 26 | -- Just "foo" 27 | -- 28 | -- >>> this (That "bar") :: Maybe String 29 | -- Nothing 30 | this :: Monad m => Choice a b -> m a 31 | this (This a) = return a 32 | this _ = safeFail "This is a that" 33 | 34 | -- | 35 | -- >>> that (This "foo") :: Maybe String 36 | -- Nothing 37 | -- 38 | -- >>> that (That "bar") :: Maybe String 39 | -- Just "bar" 40 | that :: Monad m => Choice a b -> m b 41 | that (That a) = return a 42 | that _ = safeFail "That is a this" 43 | 44 | -- | 45 | -- >>> these [This "foo", This "bar", That "baz", This "quux"] 46 | -- ["foo","bar","quux"] 47 | these :: [Choice a b] -> [a] 48 | these = concatMap this 49 | 50 | -- | 51 | -- >>> those [This "foo", This "bar", That "baz", This "quux"] 52 | -- ["baz"] 53 | those :: [Choice a b] -> [b] 54 | those = concatMap that 55 | 56 | -- | 57 | -- >>> eitherToChoice (Left 1) 58 | -- This 1 59 | -- 60 | -- >>> eitherToChoice (Right 5) 61 | -- That 5 62 | eitherToChoice :: Either a b -> Choice a b 63 | eitherToChoice = either This That 64 | 65 | -- | 66 | -- >>> mergeChoice (This 5 :: Choice Int Int) 67 | -- 5 68 | -- 69 | -- >>> mergeChoice (That 'c' :: Choice Char Char) 70 | -- 'c' 71 | mergeChoice :: Choice a a -> a 72 | mergeChoice x = 73 | case x of 74 | This y -> y 75 | That y -> y 76 | 77 | instance Bifunctor Choice where 78 | bimap f g x = 79 | case x of 80 | This a -> This (f a) 81 | That b -> That (g b) 82 | 83 | instance (Hashable a, Hashable b) => Hashable (Choice a b) where 84 | hashWithSalt s (This x) = s `hashWithSalt` (0 :: Int) `hashWithSalt` x 85 | hashWithSalt s (That x) = s `hashWithSalt` (1 :: Int) `hashWithSalt` x 86 | 87 | instance Applicative (Choice e) where 88 | pure = That 89 | This e <*> _ = This e 90 | That f <*> r = fmap f r 91 | 92 | instance Functor (Choice a) where 93 | fmap = second 94 | 95 | instance Monad (Choice e) where 96 | return = That 97 | This l >>= _ = This l 98 | That r >>= k = k r 99 | 100 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Choice a b) where 101 | arbitrary = 102 | do bool <- arbitrary 103 | if bool 104 | then fmap This arbitrary 105 | else fmap That arbitrary 106 | 107 | shrink (This a) = map This $ shrink a 108 | shrink (That b) = map That $ shrink b 109 | 110 | instance (NFData a, NFData b) => NFData (Choice a b) where 111 | rnf (This x) = rnf x 112 | rnf (That y) = rnf y 113 | -------------------------------------------------------------------------------- /strict-data/src/Data/Fail.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | module Data.Fail 12 | ( Fail(..), pattern Fail, isFail, isOk 13 | , FailT(FailT), runFailT, FIO 14 | , failEitherStr, failEitherShow, failEitherText 15 | , runExceptTFail, failInM, failInM', failInM'' 16 | , failToEither, failMaybe, failToMaybe, mapFail 17 | , failSwitch, fromFail 18 | , MonadFailure(..) 19 | , failForIOException, catFails 20 | , eitherToError, errorToEither, liftError, errorToDefault, errorToMaybe, maybeToError, runError 21 | , runExceptTorFail, maybeToFail, eitherToFail 22 | , fromFailString, partitionFails 23 | , safeFromOk 24 | , Control.Monad.Fail.MonadFail 25 | ) where 26 | 27 | 28 | import Data.Fail.Types 29 | 30 | import Control.Applicative (Alternative(..)) 31 | import Control.Exception (ErrorCall(..), IOException, catch) 32 | import Control.Monad (MonadPlus(..)) 33 | import Control.Monad.Base (MonadBase (..), liftBaseDefault) 34 | import Control.Monad.Catch (MonadThrow (..)) 35 | import Control.Monad.Except (ExceptT, runExceptT, MonadError(..)) 36 | import Control.Monad.Fail (MonadFail) 37 | import Control.Monad.Fix 38 | import Control.Monad.IO.Class 39 | import Control.Monad.Identity (runIdentity) 40 | import Control.Monad.Reader (ReaderT(..)) 41 | import Control.Monad.State (MonadState(..)) 42 | import Control.Monad.Trans (MonadTrans(..)) 43 | import Control.Monad.Trans.Control 44 | import Control.Monad.Trans.Resource (MonadResource (..)) 45 | import Control.Monad.Writer (MonadWriter(..)) 46 | import GHC.Stack 47 | import GHC.Stack.Plus 48 | import Safe.Plus 49 | import Test.QuickCheck 50 | import qualified Control.Monad.Fail 51 | import qualified Data.Text as T 52 | 53 | instance Arbitrary a => Arbitrary (Fail a) where 54 | arbitrary = 55 | oneof 56 | [ Ok <$> arbitrary 57 | , Fail <$> arbitrary 58 | ] 59 | 60 | instance MonadThrow m => MonadThrow (FailT m) where 61 | throwM = FailT . throwM 62 | 63 | instance MonadBase b m => MonadBase b (FailT m) where 64 | liftBase = liftBaseDefault 65 | 66 | instance MonadBaseControl b m => MonadBaseControl b (FailT m) where 67 | type StM (FailT m) a = ComposeSt FailT m a 68 | liftBaseWith = defaultLiftBaseWith 69 | restoreM = defaultRestoreM 70 | 71 | instance MonadTransControl FailT where 72 | type StT FailT a = Fail a 73 | liftWith f = FailT $ return <$> f runFailT 74 | restoreT = FailT 75 | 76 | instance Monad m => MonadError String (FailT m) where 77 | throwError = throwFailT 78 | catchError = catchFailT 79 | 80 | instance MonadTrans FailT where 81 | lift m = 82 | FailT $ 83 | do a <- m 84 | return (Ok a) 85 | 86 | instance MonadIO m => MonadIO (FailT m) where 87 | liftIO io = FailT $ fmap Ok (liftIO io) 88 | 89 | instance MonadState s m => MonadState s (FailT m) where 90 | get = lift get 91 | put = lift . put 92 | 93 | instance MonadResource m => MonadResource (FailT m) where 94 | liftResourceT = FailT . fmap Ok . liftResourceT 95 | 96 | instance MonadWriter w m => MonadWriter w (FailT m) where 97 | tell = lift . tell 98 | listen = 99 | mapFailT $ \m -> 100 | do (a, w) <- listen m 101 | return $! fmap (\r -> (r, w)) a 102 | pass = 103 | mapFailT $ \m -> 104 | pass $ 105 | do a <- m 106 | return $! 107 | case a of 108 | Err l -> (Err l, id) 109 | Ok (r, f) -> (Ok r, f) 110 | 111 | mapFailT :: (m (Fail a) -> n (Fail b)) -> FailT m a -> FailT n b 112 | mapFailT f = FailT . f . runFailT 113 | 114 | throwFailT :: Monad m => String -> FailT m a 115 | throwFailT l = FailT $ return (Fail l) 116 | 117 | catchFailT :: Monad m => FailT m a -> (String -> FailT m a) -> FailT m a 118 | m `catchFailT` h = 119 | FailT $ 120 | do a <- runFailT m 121 | case a of 122 | Err l -> runFailT (h $ T.unpack l) 123 | Ok r -> return (Ok r) 124 | 125 | isFail :: Fail a -> Bool 126 | isFail (Err _) = True 127 | isFail (Ok _) = False 128 | 129 | isOk :: Fail a -> Bool 130 | isOk = not . isFail 131 | 132 | instance Monad Fail where 133 | return = Ok 134 | {-# INLINE return #-} 135 | fail = Control.Monad.Fail.fail 136 | {-# INLINE fail #-} 137 | (>>=) = failBind 138 | {-# INLINE (>>=) #-} 139 | 140 | instance Control.Monad.Fail.MonadFail Fail where 141 | fail = Fail 142 | {-# INLINE fail #-} 143 | 144 | instance MonadPlus Fail where 145 | mzero = failZero 146 | mplus = failPlus 147 | 148 | instance Applicative Fail where 149 | pure = Ok 150 | (<*>) = failAp 151 | 152 | instance Alternative Fail where 153 | empty = failZero 154 | (<|>) = failPlus 155 | 156 | instance MonadFix Fail where 157 | mfix f = let a = f (unOk a) in a 158 | where 159 | unOk (Ok x) = x 160 | unOk (Err msg) = safeError ("mfix failed: " ++ T.unpack msg) 161 | 162 | instance MonadFix m => MonadFix (FailT m) where 163 | mfix f = 164 | FailT $ mfix $ \a -> runFailT $ f $ 165 | case a of 166 | Ok r -> r 167 | Err msg -> safeError ("FailT.mfix failed: " ++ T.unpack msg) 168 | 169 | instance Monad m => Monad (FailT m) where 170 | return = returnFailT 171 | fail = Control.Monad.Fail.fail 172 | (>>=) = bindFailT 173 | 174 | instance Monad m => Control.Monad.Fail.MonadFail (FailT m) where 175 | fail = FailT . return . Fail 176 | 177 | instance (Functor m, Monad m) => Applicative (FailT m) where 178 | pure = FailT . return . Ok 179 | FailT f <*> FailT v = 180 | FailT $ 181 | do mf <- f 182 | case mf of 183 | Err msg -> return (Err msg) 184 | Ok k -> 185 | do mv <- v 186 | case mv of 187 | Err msg -> return (Err msg) 188 | Ok x -> return (Ok (k x)) 189 | 190 | instance Monad m => Alternative (FailT m) where 191 | empty = FailT $ return failZero 192 | FailT f <|> FailT g = 193 | FailT $ 194 | do mf <- f 195 | mg <- g 196 | return $ mf `failPlus` mg 197 | 198 | instance Monad m => MonadPlus (FailT m) where 199 | mzero = empty 200 | mplus = (<|>) 201 | 202 | failBind :: Fail a -> (a -> Fail b) -> Fail b 203 | failBind ma f = 204 | case ma of 205 | Ok x -> {-# SCC "Fail/>>=/f" #-} (f x) 206 | -- is there a better way to avoid allocations? 207 | Err x -> {-# SCC "Fail/>>=/Fail" #-} (Err x) 208 | {-# INLINE failBind #-} 209 | 210 | failAp :: Fail (a -> b) -> Fail a -> Fail b 211 | failAp (Ok f) (Ok a) = Ok (f a) 212 | failAp (Err msg) _ = Err msg 213 | failAp _ (Err msg) = Err msg 214 | {-# INLINE failAp #-} 215 | 216 | failZero :: Fail a 217 | failZero = Fail "mzero" 218 | {-# INLINE failZero #-} 219 | 220 | failPlus :: Fail a -> Fail a -> Fail a 221 | failPlus x@(Ok _) _ = x 222 | failPlus _ x = x 223 | {-# INLINE failPlus #-} 224 | 225 | failSwitch :: (String -> c) -> (a -> c) -> Fail a -> c 226 | failSwitch _ g (Ok x) = g x 227 | failSwitch f _ (Err x) = f (T.unpack x) 228 | {-# INLINE failSwitch #-} 229 | 230 | {-# INLINE runFailT #-} 231 | runFailT :: FailT m a -> m (Fail a) 232 | runFailT = unFailT 233 | 234 | {-# INLINE returnFailT #-} 235 | returnFailT :: Monad m => a -> FailT m a 236 | returnFailT = FailT . return . Ok 237 | 238 | {-# INLINE bindFailT #-} 239 | bindFailT :: Monad m => FailT m a -> (a -> FailT m b) -> FailT m b 240 | bindFailT (FailT action) f = 241 | FailT $ 242 | do mx <- action 243 | case mx of 244 | Ok x -> unFailT (f x) 245 | Err m -> return (Err m) 246 | 247 | instance MonadError String Fail where 248 | throwError = Fail 249 | Err l `catchError` h = h (T.unpack l) 250 | Ok r `catchError` _ = Ok r 251 | 252 | failMaybe :: String -> Maybe a -> Fail a 253 | failMaybe _ (Just x) = Ok x 254 | failMaybe msg Nothing = Fail msg 255 | 256 | failEitherStr :: Either String a -> Fail a 257 | failEitherStr = either Fail Ok 258 | 259 | failEitherText :: Either T.Text a -> Fail a 260 | failEitherText = either (Fail . T.unpack) Ok 261 | 262 | failEitherShow :: Show a => Either a b -> Fail b 263 | failEitherShow e = 264 | case e of 265 | Left err -> Fail $ show err 266 | Right val -> Ok val 267 | 268 | runExceptTFail :: Monad m => ExceptT String m a -> m (Fail a) 269 | runExceptTFail err = 270 | do eith <- runExceptT err 271 | case eith of 272 | Left err -> return $ Fail err 273 | Right x -> return $ Ok x 274 | 275 | class Control.Monad.Fail.MonadFail m => MonadFailure m where 276 | catchFailure :: m a -> (String -> m a) -> m a 277 | 278 | instance MonadFailure Maybe where 279 | Nothing `catchFailure` hdl = hdl "Failed in Maybe." 280 | ok `catchFailure` _ = ok 281 | 282 | instance MonadFailure IO where 283 | catchFailure action hdl = action `catch` \(ErrorCall s) -> hdl s 284 | 285 | instance MonadFailure Fail where 286 | ok@(Ok _) `catchFailure` _ = ok 287 | Err msg `catchFailure` hdl = hdl (T.unpack msg) 288 | 289 | instance Monad m => MonadFailure (FailT m) where 290 | FailT action `catchFailure` hdl = 291 | FailT $ 292 | do result <- action 293 | case result of 294 | Err msg -> unFailT (hdl $ T.unpack msg) 295 | Ok _ -> return result 296 | 297 | instance (MonadFail (ReaderT r m), MonadFailure m) => MonadFailure (ReaderT r m) where 298 | action `catchFailure` handler = 299 | ReaderT $ \r -> 300 | runReaderT action r `catchFailure` \msg -> runReaderT (handler msg) r 301 | 302 | failInM :: Monad m => Fail a -> m a 303 | failInM f = failInM' f id 304 | 305 | failInM' :: Monad m => Fail a -> (String -> String) -> m a 306 | failInM' f h = 307 | case f of 308 | Ok x -> return x 309 | Err msg -> fail (h $ T.unpack msg) 310 | 311 | failInM'' :: Monad m => String -> Fail a -> m a 312 | failInM'' what = flip failInM' (("Failed to " ++ what ++ ":")++) 313 | 314 | mapFail :: (String -> String) -> Fail a -> Fail a 315 | mapFail f x = 316 | case x of 317 | Ok _ -> x 318 | Err msg -> Fail (f $ T.unpack msg) 319 | 320 | failToEither :: Fail a -> Either String a 321 | failToEither (Ok x) = Right x 322 | failToEither (Err x) = Left (T.unpack x) 323 | 324 | failToMaybe :: Fail a -> Maybe a 325 | failToMaybe (Ok x) = Just x 326 | failToMaybe _ = Nothing 327 | 328 | failForIOException :: IO a -> IO (Fail a) 329 | failForIOException action = 330 | catch (Ok <$> action) (\(exc::IOException) -> return (Fail (show exc))) 331 | 332 | catFails :: [Fail a] -> [a] 333 | catFails [] = [] 334 | catFails ((Err _):xs) = catFails xs 335 | catFails ((Ok a):xs) = a:(catFails xs) 336 | 337 | fromFail :: (String -> a) -> Fail a -> a 338 | fromFail f = failSwitch f id 339 | 340 | fromFailString :: Fail a -> Maybe String 341 | fromFailString f = 342 | case f of 343 | Ok _ -> Nothing 344 | Err str -> Just (T.unpack str) 345 | 346 | runError :: forall a. (forall m. Monad m => m a) -> Either String a 347 | runError x = runIdentity (runExceptT x) 348 | 349 | partitionFails :: [Fail a] -> ([a], [String]) 350 | partitionFails l = go l ([], []) 351 | where 352 | go l (good, bad) = 353 | case l of 354 | [] -> 355 | (reverse good, reverse bad) 356 | (Ok x : rest) -> 357 | go rest (x : good, bad) 358 | (Err s : rest) -> 359 | go rest (good, T.unpack s : bad) 360 | 361 | eitherToError :: MonadError e m => Either e a -> m a 362 | eitherToError = either throwError return 363 | 364 | errorToEither :: MonadError e m => m a -> m (Either e a) 365 | errorToEither m = catchError (Right <$> m) (return . Left) 366 | 367 | errorToDefault :: MonadError e m => a -> m a -> m a 368 | errorToDefault a ma = catchError ma (\_ -> return a) 369 | 370 | liftError :: (MonadError e m, MonadError e m1) => (forall a. m a -> m1 a) -> m a -> m1 a 371 | liftError liftBase action = liftBase (errorToEither action) >>= eitherToError 372 | 373 | errorToMaybe :: MonadError e m => m a -> m (Maybe a) 374 | errorToMaybe ma = catchError (Just <$> ma) (\_ -> return Nothing) 375 | 376 | maybeToError :: MonadError e m => String -> Maybe a -> m a 377 | maybeToError msg ma = 378 | case ma of 379 | Nothing -> safeFail msg 380 | Just a -> return a 381 | 382 | maybeToFail :: Monad m => String -> Maybe a -> m a 383 | maybeToFail msg ma = 384 | case ma of 385 | Nothing -> safeFail msg 386 | Just a -> return a 387 | 388 | eitherToFail :: Monad m => Either String a -> m a 389 | eitherToFail = either safeFail return 390 | 391 | runExceptTorFail :: (Monad m, Show e) => ExceptT e m a -> m a 392 | runExceptTorFail action = 393 | do result <- runExceptT action 394 | either (safeFail . show) return result 395 | 396 | safeFromOk :: (HasCallStack) => Fail a -> a 397 | safeFromOk f = 398 | case f of 399 | Ok x -> x 400 | Err msg -> safeError $ callerLocation ++ ": Fail " ++ show msg 401 | -------------------------------------------------------------------------------- /strict-data/src/Data/Fail/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | module Data.Fail.Types 8 | ( Fail(..), pattern Fail 9 | , FailT(..) 10 | , FIO 11 | ) 12 | where 13 | 14 | import qualified Data.Text as T 15 | 16 | pattern Fail :: String -> Fail a 17 | pattern Fail x <- Err (T.unpack -> x) where 18 | Fail x = Err (T.pack x) 19 | 20 | #if (MIN_VERSION_base(4,10,0)) 21 | {-# COMPLETE Ok, Fail #-} 22 | #endif 23 | 24 | data Fail a 25 | = Err T.Text 26 | | Ok !a 27 | deriving (Show, Ord, Eq, Functor, Foldable, Traversable) 28 | 29 | newtype FailT m a = FailT { unFailT :: m (Fail a) } 30 | deriving (Functor) 31 | 32 | type FIO a = FailT IO a 33 | -------------------------------------------------------------------------------- /strict-data/src/Data/Map/Ordered.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveFoldable #-} 5 | {-# LANGUAGE BangPatterns #-} 6 | -- | An ordered, strict map. 7 | -- 8 | -- One might think that `Data.Map.Strict` already provides such a data type. This is not correct. 9 | -- `Data.Map.Lazy` and `Data.Map.Strict` use the same, non-strict `Map` datatype. 10 | -- `Data.Map.Strict` just provides functions that evaluate the value argument before inserting it 11 | -- in the Map. The problem is that the typeclass instances of the shared `Map` datatype use the 12 | -- non-strict functions. 13 | module Data.Map.Ordered 14 | ( OSMap, Map, empty, lookup, insert, delete, fromList, fromListWith, toList, map, mapMaybe 15 | , lookupLT, lookupGT, lookupLE, lookupGE, lookupM, elemAt 16 | , singleton, insertWith 17 | , member, elems, unionWith, difference, union, findWithDefault, size, null, isSubmapOf, unions 18 | , intersection, foldrWithKey, foldlWithKey, filter, filterWithKey 19 | , keys, toDescList, updateLookupWithKey 20 | , deleteLookup, insertLookupWithKey, adjust, assocs, insertWith' 21 | , alter, differenceWith, updateWithKey, update, mapKeys, insertWithKey, insertWithKey' 22 | , keysSet 23 | , maxView, maxViewWithKey, minView, minViewWithKey 24 | , intersectionWith, fromDistinctAscList 25 | , toDataMap, fromDataMap, hasKey, hasValue 26 | ) 27 | where 28 | 29 | import Control.Arrow (second) 30 | import Control.DeepSeq (NFData(..)) 31 | import Data.Coerce 32 | import Data.Data 33 | import Data.Hashable 34 | import Data.List (foldl') 35 | import Data.Maybe (isJust) 36 | import Prelude hiding (map, lookup, null, filter) 37 | import Test.QuickCheck 38 | import qualified Data.Map.Strict as DM 39 | import qualified Data.Set as Set 40 | 41 | type Map = OSMap 42 | 43 | newtype OSMap k v = OSMap { unOSMap :: DM.Map k v } 44 | deriving (Eq, Ord, Read, Show, Foldable, NFData, Data) 45 | 46 | instance (Hashable k, Hashable v) => Hashable (OSMap k v) where 47 | hashWithSalt = foldlWithKey updateHash 48 | where 49 | updateHash salt k v = hashWithSalt salt k `hashWithSalt` v 50 | 51 | instance Functor (OSMap k) where 52 | {-# INLINE fmap #-} 53 | fmap = map 54 | 55 | instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (OSMap k v) where 56 | arbitrary = OSMap <$> arbitrary 57 | shrink = coerce . shrink . unOSMap 58 | 59 | instance Traversable (OSMap k) where 60 | {-# INLINE traverse #-} 61 | traverse f (OSMap m) = 62 | fromDataMap <$> DM.traverseWithKey (\_ x -> let y = f x in y) m 63 | 64 | instance (Ord k) => Monoid (OSMap k v) where 65 | mempty = empty 66 | mconcat = unions 67 | mappend = union 68 | 69 | {-# INLINE fromDataMap #-} 70 | fromDataMap :: DM.Map k v -> OSMap k v 71 | fromDataMap dm = DM.foldr (\a b -> a `seq` b) () dm `seq` OSMap dm 72 | 73 | {-# INLINE toDataMap #-} 74 | toDataMap :: OSMap k v -> DM.Map k v 75 | toDataMap = unOSMap 76 | 77 | {-# INLINE empty #-} 78 | empty :: OSMap k v 79 | empty = OSMap DM.empty 80 | 81 | {-# INLINE member #-} 82 | member :: (Ord k) => k -> OSMap k v -> Bool 83 | member k (OSMap m) = DM.member k m 84 | 85 | {-# INLINE lookup #-} 86 | lookup :: (Ord k) => k -> OSMap k v -> Maybe v 87 | lookup k (OSMap hm) = DM.lookup k hm 88 | 89 | {-# INLINE lookupM #-} 90 | lookupM :: (Show k, Ord k, Monad m) => k -> OSMap k v -> m v 91 | lookupM k (OSMap hm) = 92 | case DM.lookup k hm of 93 | Nothing -> fail ("Could not find " ++ show k ++ " in Map.") 94 | Just x -> pure x 95 | 96 | {-# INLINE lookupLT #-} 97 | lookupLT :: (Ord k) => k -> OSMap k v -> Maybe (k, v) 98 | lookupLT k (OSMap hm) = DM.lookupLT k hm 99 | 100 | {-# INLINE lookupGT #-} 101 | lookupGT :: (Ord k) => k -> OSMap k v -> Maybe (k, v) 102 | lookupGT k (OSMap hm) = DM.lookupGT k hm 103 | 104 | {-# INLINE lookupLE #-} 105 | lookupLE :: (Ord k) => k -> OSMap k v -> Maybe (k, v) 106 | lookupLE k (OSMap hm) = DM.lookupLE k hm 107 | 108 | {-# INLINE lookupGE #-} 109 | lookupGE :: (Ord k) => k -> OSMap k v -> Maybe (k, v) 110 | lookupGE k (OSMap hm) = DM.lookupGE k hm 111 | 112 | {-# INLINE insert #-} 113 | insert :: (Ord k) => k -> v -> OSMap k v -> OSMap k v 114 | insert k v (OSMap hm) = OSMap (DM.insert k v hm) 115 | 116 | {-# INLINE delete #-} 117 | delete :: (Ord k) => k -> OSMap k v -> OSMap k v 118 | delete k (OSMap hm) = OSMap (DM.delete k hm) 119 | 120 | {-# INLINE fromList #-} 121 | fromList :: (Ord k) => [(k,v)] -> OSMap k v 122 | fromList = OSMap . DM.fromList 123 | 124 | {-# INLINE fromListWith #-} 125 | fromListWith :: (Ord k) => (v -> v -> v) -> [(k,v)] -> OSMap k v 126 | fromListWith f kvs = OSMap $ DM.fromListWith f kvs 127 | 128 | {-# INLINE toList #-} 129 | toList :: OSMap k v -> [(k, v)] 130 | toList (OSMap hm) = DM.toList hm 131 | 132 | {-# INLINE toDescList #-} 133 | toDescList :: OSMap k v -> [(k, v)] 134 | toDescList (OSMap hm) = DM.toDescList hm 135 | 136 | {-# INLINE map #-} 137 | map :: (v -> v') -> OSMap k v -> OSMap k v' 138 | map f (OSMap m) = OSMap (DM.map f m) 139 | 140 | {-# INLINE mapMaybe #-} 141 | mapMaybe :: (v -> Maybe v') -> OSMap k v -> OSMap k v' 142 | mapMaybe f (OSMap m) = OSMap (DM.mapMaybe f m) 143 | 144 | {-# INLINE singleton #-} 145 | singleton :: k -> v -> OSMap k v 146 | singleton k v = OSMap (DM.singleton k v) 147 | 148 | {-# INLINE insertWith #-} 149 | insertWith :: (Ord k) => (v -> v -> v) -> k -> v -> OSMap k v -> OSMap k v 150 | insertWith f k !v (OSMap hm) = OSMap (DM.insertWith f k v hm) 151 | 152 | {-# INLINE elems #-} 153 | elems :: OSMap k v -> [v] 154 | elems = DM.elems . unOSMap 155 | 156 | {-# INLINE keys #-} 157 | keys :: OSMap k v -> [k] 158 | keys = DM.keys . unOSMap 159 | 160 | {-# INLINE keysSet #-} 161 | keysSet :: OSMap k v -> Set.Set k 162 | keysSet = DM.keysSet . unOSMap 163 | 164 | {-# INLINE union #-} 165 | union :: Ord k => OSMap k v -> OSMap k v -> OSMap k v 166 | union (OSMap m1) (OSMap m2) = OSMap (DM.union m1 m2) 167 | 168 | {-# INLINABLE unions #-} 169 | unions :: Ord k => [OSMap k v] -> OSMap k v 170 | unions ts = foldl' union empty ts 171 | 172 | {-# INLINE unionWith #-} 173 | unionWith :: Ord k => (v -> v -> v) -> OSMap k v -> OSMap k v -> OSMap k v 174 | unionWith f (OSMap m1) (OSMap m2) = OSMap (DM.unionWith f m1 m2) 175 | 176 | {-# INLINE difference #-} 177 | difference :: (Ord k) => OSMap k v -> OSMap k w -> OSMap k v 178 | difference (OSMap m1) (OSMap m2) = OSMap (DM.difference m1 m2) 179 | 180 | {-# INLINE intersection #-} 181 | intersection :: (Ord k) => OSMap k v -> OSMap k w -> OSMap k v 182 | intersection (OSMap m1) (OSMap m2) = OSMap (DM.intersection m1 m2) 183 | 184 | {-# INLINE findWithDefault #-} 185 | findWithDefault :: (Ord k) => a -> k -> OSMap k a -> a 186 | findWithDefault def k (OSMap m) = DM.findWithDefault def k m 187 | 188 | {-# INLINE elemAt #-} 189 | elemAt :: Int -> OSMap k a -> (k, a) 190 | elemAt n (OSMap m) = DM.elemAt n m 191 | 192 | {-# INLINE size #-} 193 | size :: OSMap k v -> Int 194 | size = DM.size . unOSMap 195 | 196 | {-# INLINE null #-} 197 | null :: OSMap k v -> Bool 198 | null = DM.null . unOSMap 199 | 200 | {-# INLINE isSubmapOf #-} 201 | isSubmapOf :: (Ord k, Eq a) => OSMap k a -> OSMap k a -> Bool 202 | isSubmapOf (OSMap a) (OSMap b) = DM.isSubmapOf a b 203 | 204 | {-# INLINE foldrWithKey #-} 205 | foldrWithKey :: (k -> v -> a -> a) -> a -> OSMap k v -> a 206 | foldrWithKey f a (OSMap hm) = DM.foldrWithKey f a hm 207 | 208 | {-# INLINE foldlWithKey #-} 209 | foldlWithKey :: (a -> k -> v -> a) -> a -> OSMap k v -> a 210 | foldlWithKey f a (OSMap hm) = DM.foldlWithKey f a hm 211 | 212 | {-# INLINE filter #-} 213 | filter :: (v -> Bool) -> OSMap k v -> OSMap k v 214 | filter f (OSMap m) = OSMap (DM.filter f m) 215 | 216 | {-# INLINE filterWithKey #-} 217 | filterWithKey :: (k -> v -> Bool) -> OSMap k v -> OSMap k v 218 | filterWithKey f (OSMap m) = OSMap (DM.filterWithKey f m) 219 | 220 | {-# INLINE updateLookupWithKey #-} 221 | updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> OSMap k a -> (Maybe a, OSMap k a) 222 | updateLookupWithKey f k (OSMap curMap) = 223 | let (mv, newMap) = DM.updateLookupWithKey f k curMap 224 | in (mv, OSMap newMap) 225 | 226 | {-# INLINE deleteLookup #-} 227 | deleteLookup :: Ord k => k -> OSMap k v -> (Maybe v, OSMap k v) 228 | deleteLookup = updateLookupWithKey (\_k _v -> Nothing) 229 | 230 | {-# INLINE insertLookupWithKey #-} 231 | insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> OSMap k a -> (Maybe a, OSMap k a) 232 | insertLookupWithKey f k !newV (OSMap curM) = 233 | let (mOldV, newM) = DM.insertLookupWithKey f k newV curM 234 | in (mOldV, OSMap newM) 235 | 236 | {-# INLINE adjust #-} 237 | adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a 238 | adjust f k = OSMap . DM.adjust f k . unOSMap 239 | 240 | {-# INLINE assocs #-} 241 | assocs :: OSMap k a -> [(k, a)] 242 | assocs = DM.assocs . unOSMap 243 | 244 | {-# INLINE insertWith' #-} 245 | insertWith' :: Ord k => (a -> a -> a) -> k -> a -> OSMap k a -> OSMap k a 246 | insertWith' f k !v (OSMap dm) = OSMap (DM.insertWith f k v dm) 247 | 248 | {-# INLINE alter #-} 249 | alter :: Ord k => (Maybe a -> Maybe a) -> k -> OSMap k a -> OSMap k a 250 | alter f k (OSMap dm) = OSMap (DM.alter f k dm) 251 | 252 | {-# INLINE differenceWith #-} 253 | differenceWith :: Ord k => (a -> b -> Maybe a) -> OSMap k a -> OSMap k b -> OSMap k a 254 | differenceWith f (OSMap dmA) (OSMap dmB) = OSMap (DM.differenceWith f dmA dmB) 255 | 256 | {-# INLINE updateWithKey #-} 257 | updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> OSMap k a -> OSMap k a 258 | updateWithKey f k (OSMap dm) = OSMap (DM.updateWithKey f k dm) 259 | 260 | {-# INLINE update #-} 261 | update :: Ord k => (a -> Maybe a) -> k -> OSMap k a -> OSMap k a 262 | update f k (OSMap dm) = OSMap (DM.update f k dm) 263 | 264 | {-# INLINE insertWithKey #-} 265 | insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a 266 | insertWithKey f k !v (OSMap dm) = OSMap (DM.insertWithKey f k v dm) 267 | 268 | {-# INLINE insertWithKey' #-} 269 | insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a 270 | insertWithKey' = insertWithKey 271 | 272 | {-# INLINE mapKeys #-} 273 | mapKeys :: Ord k2 => (k1 -> k2) -> OSMap k1 a -> OSMap k2 a 274 | mapKeys f (OSMap dm) = OSMap (DM.mapKeys f dm) 275 | 276 | {-# INLINE maxView #-} 277 | maxView :: OSMap k a -> Maybe (a, OSMap k a) 278 | maxView (OSMap m) = fmap (second OSMap) (DM.maxView m) 279 | 280 | {-# INLINE maxViewWithKey #-} 281 | maxViewWithKey :: OSMap k a -> Maybe ((k, a), OSMap k a) 282 | maxViewWithKey (OSMap m) = fmap (second OSMap) (DM.maxViewWithKey m) 283 | 284 | {-# INLINE minView #-} 285 | minView :: OSMap k a -> Maybe (a, OSMap k a) 286 | minView (OSMap m) = fmap (second OSMap) (DM.minView m) 287 | 288 | {-# INLINE minViewWithKey #-} 289 | minViewWithKey :: OSMap k a -> Maybe ((k, a), OSMap k a) 290 | minViewWithKey = fmap (second OSMap) . DM.minViewWithKey . unOSMap 291 | 292 | {-# INLINE intersectionWith #-} 293 | intersectionWith :: Ord k => (a -> b -> c) -> OSMap k a -> OSMap k b -> OSMap k c 294 | intersectionWith f (OSMap l) (OSMap r) = 295 | OSMap (DM.intersectionWith f l r) 296 | 297 | {-# INLINE fromDistinctAscList #-} 298 | fromDistinctAscList :: [(k,v)] -> OSMap k v 299 | fromDistinctAscList = OSMap . DM.fromDistinctAscList 300 | 301 | hasValue :: Int -> OSMap Int Int -> Bool 302 | hasValue v m = any (\(_, x) -> x == v) (toList m) 303 | 304 | hasKey :: Int -> OSMap Int Int -> Bool 305 | hasKey k m = isJust (lookup k m) 306 | -------------------------------------------------------------------------------- /strict-data/src/Data/Map/Unordered.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE DeriveFoldable #-} 6 | {-# LANGUAGE ExistentialQuantification #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | -- | An unordered, strict map. 10 | module Data.Map.Unordered 11 | ( USMap, Map, empty, lookup, insert, delete, fromList, toList, map, singleton, insertWith 12 | , member, elems, unionWith, difference, union, findWithDefault, size, null, isSubmapOf 13 | , intersection, foldrWithKey, foldlWithKey, foldlWithKey', keys, insertLookupWithKey 14 | , updateLookupWithKey, adjust, deleteLookup, assocs, insertWith', update, alter 15 | , lookup', unions, toHashMap, fromHashMap, filter, filterWithKey, keysSet, lookupDefault 16 | , fromListWith, mapMaybe, unionsWith 17 | ) 18 | where 19 | 20 | 21 | import Control.DeepSeq (NFData(..)) 22 | import Data.Data 23 | import Data.Hashable (Hashable(..)) 24 | import Data.Maybe (isJust) 25 | import Prelude hiding (map, lookup, null, filter, pred) 26 | import Test.QuickCheck (Arbitrary(..)) 27 | import qualified Data.HashMap.Strict as HM 28 | import qualified Data.HashSet as Set 29 | import qualified Data.List as List 30 | 31 | 32 | type Map = USMap 33 | 34 | newtype USMap k v = USMap { unUSMap :: HM.HashMap k v } 35 | deriving (Eq, Functor, Foldable, Traversable, Typeable, Data, Monoid) 36 | 37 | instance (Hashable k, Eq k, Read k, Read v) => Read (USMap k v) where 38 | readsPrec p s = 39 | do (l, r) <- readsPrec p s 40 | return (fromList l, r) 41 | 42 | instance (Show k, Show v) => Show (USMap k v) where 43 | showsPrec p usmap = showsPrec p (toList usmap) 44 | 45 | instance (Hashable k, Hashable v) => Hashable (USMap k v) where 46 | hashWithSalt s (USMap hm) = hashWithSalt s hm 47 | 48 | instance (NFData k, NFData v) => NFData (USMap k v) where 49 | rnf (USMap x) = rnf x 50 | 51 | instance (Hashable k, Eq k, Arbitrary k, Arbitrary v) => Arbitrary (USMap k v) where 52 | arbitrary = fromList <$> arbitrary 53 | 54 | toHashMap :: USMap k v -> HM.HashMap k v 55 | toHashMap = unUSMap 56 | 57 | fromHashMap :: HM.HashMap k v -> USMap k v 58 | fromHashMap = USMap 59 | 60 | empty :: USMap k v 61 | empty = USMap HM.empty 62 | 63 | member :: (Eq k, Hashable k) => k -> USMap k v -> Bool 64 | member k (USMap m) = 65 | case HM.lookup k m of 66 | Just _ -> True 67 | Nothing -> False 68 | 69 | lookupDefault :: (Eq k, Hashable k) => v -> k -> USMap k v -> v 70 | lookupDefault d k (USMap hm) = HM.lookupDefault d k hm 71 | 72 | {-# SPECIALISE lookup :: (Eq k, Hashable k, Show k) => k -> USMap k v -> Maybe v #-} 73 | {-# INLINEABLE lookup #-} 74 | lookup :: (Eq k, Show k, Hashable k, Monad m) => k -> USMap k v -> m v 75 | lookup k (USMap hm) = 76 | case HM.lookup k hm of 77 | Nothing -> fail ("Key " ++ show k ++ " not found.") 78 | Just x -> return x 79 | 80 | {-# INLINE lookup' #-} 81 | lookup' :: (Eq k, Hashable k) => k -> USMap k v -> Maybe v 82 | lookup' k (USMap hm) = HM.lookup k hm 83 | 84 | insert :: (Eq k, Hashable k) => k -> v -> USMap k v -> USMap k v 85 | insert k v (USMap hm) = USMap (HM.insert k v hm) 86 | 87 | delete :: (Eq k, Hashable k) => k -> USMap k v -> USMap k v 88 | delete k (USMap hm) = USMap (HM.delete k hm) 89 | 90 | fromList :: (Eq k, Hashable k) => [(k,v)] -> USMap k v 91 | fromList = USMap . HM.fromList 92 | 93 | fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> USMap k v 94 | fromListWith f = USMap . HM.fromListWith f 95 | 96 | toList :: USMap k v -> [(k, v)] 97 | toList (USMap hm) = HM.toList hm 98 | 99 | map :: (v -> v') -> USMap k v -> USMap k v' 100 | map f = USMap . HM.map f . unUSMap 101 | 102 | mapMaybe :: (v -> Maybe v') -> USMap k v -> USMap k v' 103 | mapMaybe f = USMap . HM.mapMaybe f . unUSMap 104 | 105 | singleton :: Hashable k => k -> v -> USMap k v 106 | singleton k = USMap . HM.singleton k 107 | 108 | insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> USMap k v -> USMap k v 109 | insertWith f k v (USMap hm) = USMap (HM.insertWith f k v hm) 110 | 111 | elems :: USMap k v -> [v] 112 | elems = HM.elems . unUSMap 113 | 114 | keys :: USMap k v -> [k] 115 | keys = HM.keys . unUSMap 116 | 117 | keysSet :: (Eq k, Hashable k) => USMap k v -> Set.HashSet k 118 | keysSet = Set.fromList . fmap fst . toList 119 | 120 | union :: (Hashable k, Eq k) => USMap k v -> USMap k v -> USMap k v 121 | union (USMap m1) (USMap m2) = USMap (HM.union m1 m2) 122 | 123 | unionWith :: (Hashable k, Eq k) => (v -> v -> v) -> USMap k v -> USMap k v -> USMap k v 124 | unionWith f (USMap m1) (USMap m2) = USMap (HM.unionWith f m1 m2) 125 | 126 | difference :: (Eq k, Hashable k) => USMap k v -> USMap k w -> USMap k v 127 | difference (USMap m1) (USMap m2) = USMap (HM.difference m1 m2) 128 | 129 | intersection :: (Eq k, Hashable k) => USMap k v -> USMap k w -> USMap k v 130 | intersection (USMap m1) (USMap m2) = USMap (HM.intersection m1 m2) 131 | 132 | findWithDefault :: (Eq k, Hashable k) => a -> k -> USMap k a -> a 133 | findWithDefault def k (USMap m) = 134 | case HM.lookup k m of 135 | Just v -> v 136 | Nothing -> def 137 | 138 | size :: USMap k v -> Int 139 | size = HM.size . unUSMap 140 | 141 | null :: USMap k v -> Bool 142 | null = HM.null . unUSMap 143 | 144 | isSubmapOf :: (Hashable k, Eq k) => USMap k a -> USMap k a -> Bool 145 | isSubmapOf a b = null (a `difference` b) 146 | 147 | foldrWithKey :: (k -> v -> a -> a) -> a -> USMap k v -> a 148 | foldrWithKey f a (USMap hm) = HM.foldrWithKey f a hm 149 | 150 | {-# WARNING foldlWithKey "This function is strict. Better explicitly use USMap.foldlWithKey'" #-} 151 | foldlWithKey :: (a -> k -> v -> a) -> a -> USMap k v -> a 152 | foldlWithKey f a (USMap hm) = HM.foldlWithKey' f a hm 153 | 154 | foldlWithKey' :: (a -> k -> v -> a) -> a -> USMap k v -> a 155 | foldlWithKey' f a (USMap hm) = HM.foldlWithKey' f a hm 156 | 157 | filterWithKey :: (k -> v -> Bool) -> USMap k v -> USMap k v 158 | filterWithKey pred (USMap hm) = USMap $! HM.filterWithKey pred hm 159 | 160 | filter :: (v -> Bool) -> USMap k v -> USMap k v 161 | filter pred (USMap hm) = USMap $! HM.filter pred hm 162 | 163 | insertLookupWithKey :: (Eq k, Hashable k) => (k -> a -> a -> a) -> k -> a -> USMap k a 164 | -> (Maybe a, USMap k a) 165 | insertLookupWithKey f k newV m = 166 | case lookup' k m of 167 | justV@(Just oldV) -> (justV, insert k (f k newV oldV) m) 168 | nothing@Nothing -> (nothing, insert k newV m) 169 | 170 | updateLookupWithKey :: (Eq k, Hashable k) => (k -> a -> Maybe a) -> k -> USMap k a 171 | -> (Maybe a, USMap k a) 172 | updateLookupWithKey f k m = 173 | case lookup' k m of 174 | Just oldV -> 175 | case f k oldV of 176 | justV@(Just newV) -> (justV, insert k newV m) 177 | Nothing -> (Just oldV, delete k m) 178 | Nothing -> (Nothing, m) 179 | 180 | adjust :: (Eq k, Hashable k) => (a -> a) -> k -> USMap k a -> USMap k a 181 | adjust f k (USMap hm) = USMap (HM.adjust f k hm) 182 | 183 | deleteLookup :: (Eq k, Hashable k) => k -> USMap k a -> (Maybe a, USMap k a) 184 | deleteLookup k m = (lookup' k m, delete k m) 185 | 186 | {-# INLINE assocs #-} 187 | assocs :: USMap k a -> [(k, a)] 188 | assocs = HM.toList . unUSMap 189 | 190 | {-# INLINE insertWith' #-} 191 | insertWith' :: (Eq k, Hashable k) => (a -> a -> a) -> k -> a -> USMap k a -> USMap k a 192 | insertWith' f k !v (USMap hm) = USMap (HM.insertWith f k v hm) 193 | 194 | {-# INLINE update #-} 195 | update :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> USMap k a -> USMap k a 196 | update f k um@(USMap hm) = 197 | case HM.lookup k hm of 198 | Just curV -> 199 | case f curV of 200 | Nothing -> USMap (HM.delete k hm) 201 | Just newV -> USMap (HM.insert k newV hm) 202 | Nothing -> um 203 | 204 | {-# INLINE alter #-} 205 | alter :: (Eq k, Hashable k) => (Maybe a -> Maybe a) -> k -> USMap k a -> USMap k a 206 | alter f k um@(USMap hm) = 207 | let mOld = HM.lookup k hm 208 | mNew = f mOld 209 | in case mNew of 210 | Nothing 211 | | isJust mOld -> USMap (HM.delete k hm) 212 | | otherwise -> um 213 | Just new -> USMap (HM.insert k new hm) 214 | 215 | unions :: (Hashable k, Eq k) => [USMap k a] -> USMap k a 216 | unions = List.foldl' union empty 217 | 218 | unionsWith :: (Hashable k, Eq k) => (a -> a -> a) -> [USMap k a] -> USMap k a 219 | unionsWith f = List.foldl' (unionWith f) empty 220 | -------------------------------------------------------------------------------- /strict-data/src/Data/Option.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | module Data.Option where 7 | 8 | import Data.Fail 9 | import Data.StrictList.Types 10 | 11 | import Control.Applicative 12 | import Control.DeepSeq 13 | import Control.Monad 14 | import Control.Monad.Trans 15 | import Data.Aeson 16 | import Data.Data 17 | import Data.Hashable 18 | import GHC.Generics (Generic) 19 | import Safe.Plus 20 | import Test.QuickCheck 21 | import qualified Control.Monad.Fail as Fail 22 | 23 | data Option a 24 | = None 25 | | Some !a 26 | deriving (Show, Read, Eq, Generic, Typeable, Data, Functor, Foldable, Traversable) 27 | 28 | instance Applicative Option where 29 | pure = Some 30 | {-# INLINE pure #-} 31 | 32 | f <*> x = 33 | case f of 34 | Some g -> fmap g x 35 | None -> None 36 | {-# INLINE (<*>) #-} 37 | 38 | instance Monad Option where 39 | (Some x) >>= k = k x 40 | None >>= _ = None 41 | (>>) = (*>) 42 | fail _ = None 43 | 44 | instance Monoid a => Monoid (Option a) where 45 | mempty = None 46 | None `mappend` m = m 47 | m `mappend` None = m 48 | Some m1 `mappend` Some m2 = Some (m1 `mappend` m2) 49 | 50 | instance Alternative Option where 51 | empty = None 52 | None <|> r = r 53 | l <|> _ = l 54 | 55 | instance MonadPlus Option 56 | 57 | instance ToJSON a => ToJSON (Option a) where 58 | toJSON = toJSON . optionToMaybe 59 | {-# INLINE toJSON #-} 60 | 61 | instance FromJSON a => FromJSON (Option a) where 62 | parseJSON x = maybeToOption <$> parseJSON x 63 | {-# INLINE parseJSON #-} 64 | 65 | newtype OptionT m a 66 | = OptionT 67 | { runOptionT :: m (Option a) 68 | } 69 | 70 | runOptionTDef :: Functor m => a -> OptionT m a -> m a 71 | runOptionTDef x = fmap (fromOption x) . runOptionT 72 | 73 | class ToOptionT t where 74 | optionT :: Monad m => m (t a) -> OptionT m a 75 | 76 | instance ToOptionT Maybe where 77 | optionT = OptionT . fmap maybeToOption 78 | 79 | instance ToOptionT Option where 80 | optionT = OptionT 81 | 82 | instance Functor m => Functor (OptionT m) where 83 | fmap f = OptionT . fmap (fmap f) . runOptionT 84 | 85 | instance (Functor m, Monad m) => Applicative (OptionT m) where 86 | pure = return 87 | (<*>) = ap 88 | 89 | instance Monad m => Fail.MonadFail (OptionT m) where 90 | fail _ = OptionT (return None) 91 | 92 | instance Monad m => Monad (OptionT m) where 93 | fail = safeFail 94 | return = lift . return 95 | x >>= f = OptionT (runOptionT x >>= option (return None) (runOptionT . f)) 96 | 97 | instance Ord a => Ord (Option a) where 98 | compare x y = 99 | case x of 100 | Some a -> 101 | case y of 102 | Some b -> compare a b 103 | None -> GT 104 | None -> 105 | case y of 106 | None -> EQ 107 | Some _ -> LT 108 | 109 | instance NFData a => NFData (Option a) where 110 | rnf None = () 111 | rnf (Some b) = rnf b 112 | 113 | instance MonadTrans OptionT where 114 | lift x = OptionT (Some <$> x) 115 | 116 | instance (MonadIO m) => MonadIO (OptionT m) where 117 | liftIO = lift . liftIO 118 | 119 | instance Fail.MonadFail Option where 120 | fail _ = None 121 | 122 | instance Arbitrary a => Arbitrary (Option a) where 123 | arbitrary = frequency [(1, return None), (3, Some <$> arbitrary)] 124 | 125 | shrink (Some x) = None : [ Some x' | x' <- shrink x ] 126 | shrink _ = [] 127 | 128 | noneIf :: (a -> Bool) -> a -> Option a 129 | noneIf p x 130 | | p x = None 131 | | otherwise = Some x 132 | 133 | fromOption :: a -> Option a -> a 134 | fromOption def opt = 135 | case opt of 136 | Some x -> x 137 | None -> def 138 | 139 | isSome :: Option a -> Bool 140 | isSome (Some _) = True 141 | isSome _ = False 142 | 143 | isNone :: Option a -> Bool 144 | isNone None = True 145 | isNone _ = False 146 | 147 | optionToMaybe :: Option a -> Maybe a 148 | optionToMaybe (Some a) = Just a 149 | optionToMaybe None = Nothing 150 | {-# INLINE optionToMaybe #-} 151 | 152 | -- | 153 | -- prop> maybeToOption (optionToMaybe x) == x 154 | maybeToOption :: Maybe a -> Option a 155 | maybeToOption (Just a) = Some a 156 | maybeToOption Nothing = None 157 | {-# INLINE maybeToOption #-} 158 | 159 | optionToList :: Option a -> [a] 160 | optionToList (Some a) = [a] 161 | optionToList None = [] 162 | 163 | optionToSL :: Option a -> StrictList a 164 | optionToSL (Some a) = a :! Nil 165 | optionToSL None = Nil 166 | 167 | listToOption :: [a] -> Option a 168 | listToOption [] = None 169 | listToOption (x:_) = Some x 170 | 171 | getSomeNote :: Monad m => String -> Option a -> m a 172 | getSomeNote str = option (safeFail str) return 173 | 174 | option :: b -> (a -> b) -> Option a -> b 175 | option def f opt = 176 | case opt of 177 | Some a -> f $! a 178 | None -> def 179 | 180 | catOptions :: [Option a] -> [a] 181 | catOptions ls = [x | Some x <- ls] 182 | 183 | mapOption :: (a -> Option b) -> [a] -> [b] 184 | mapOption _ [] = [] 185 | mapOption f (x:xs) = 186 | let rs = mapOption f xs in 187 | case f x of 188 | None -> rs 189 | Some r -> r : rs 190 | 191 | instance Hashable a => Hashable (Option a) 192 | 193 | forOptionM :: Monad m => [a] -> (a -> OptionT m b) -> m [b] 194 | forOptionM xs f = catOptions <$> forM xs (runOptionT . f) 195 | 196 | mapOptionM :: Monad m => (a -> OptionT m b) -> [a] -> m [b] 197 | mapOptionM = flip forOptionM 198 | 199 | safeFromSome :: Option a -> a 200 | safeFromSome = fromOption (safeError "fromSome is None!") 201 | 202 | failToOption :: Fail a -> Option a 203 | failToOption (Ok x) = Some x 204 | failToOption _ = None 205 | 206 | optionToFail :: String -> Option a -> Fail a 207 | optionToFail _ (Some x) = Ok x 208 | optionToFail err None = Fail err 209 | 210 | optionToFailT :: Monad m => String -> Option a -> FailT m a 211 | optionToFailT _ (Some x) = return x 212 | optionToFailT err None = safeFail err 213 | -------------------------------------------------------------------------------- /strict-data/src/Data/StrictList.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE MonadComprehensions #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | module Data.StrictList 9 | ( StrictList(..) 10 | , SL 11 | , (+!+) 12 | , (\!\) 13 | , all 14 | , any 15 | , atIdx 16 | , break 17 | , catMaybes 18 | , catOptions 19 | , catOptionsL 20 | , concat 21 | , concatSL 22 | , concatMap 23 | , concatMapSL 24 | , concatMapM 25 | , concatText 26 | , delete 27 | , deleteBy 28 | , deleteIdx 29 | , drop 30 | , dropWhile 31 | , dropWhileEnd 32 | , elem 33 | , filter 34 | , find 35 | , findIndex 36 | , fromLazyList, toLazyList 37 | , groupBy 38 | , headM 39 | , headOpt 40 | , insert 41 | , insertBy 42 | , intercalateString 43 | , intercalateText 44 | , intersperse 45 | , lastM 46 | , lastOpt 47 | , length 48 | , ll 49 | , lookup 50 | , lookupM 51 | , lookupM' 52 | , lookupM'' 53 | , map 54 | , mapM 55 | , mapM_ 56 | , mapMaybe 57 | , mapOption 58 | , maximumM 59 | , maybeToStrictList 60 | , mconcatSL 61 | , notElem 62 | , nub 63 | , null 64 | , optionToStrictList 65 | , partition 66 | , replicate 67 | , reverse 68 | , singleton 69 | , sl 70 | , snoc 71 | , merge 72 | , mergeBy 73 | , sort 74 | , sortBy 75 | , sortOn 76 | , span 77 | , stripPrefix 78 | , stripSuffix 79 | , tailOpt 80 | , take 81 | , takeWhile 82 | , transpose 83 | , unzip 84 | , unzipL 85 | , unzipLL 86 | , zip 87 | , zipLL 88 | , zipLS 89 | , zipSL 90 | , zipWith 91 | , zipWithLS 92 | , zipWithSL 93 | ) 94 | where 95 | 96 | import Data.Option hiding (catOptions, mapOption) 97 | import Data.StrictList.Types 98 | import Data.StrictTuple 99 | 100 | import Data.Hashable 101 | import Data.Ord (comparing) 102 | import Prelude hiding 103 | ( (!!) 104 | , all 105 | , any 106 | , break 107 | , concat 108 | , concatMap 109 | , drop 110 | , dropWhile 111 | , elem 112 | , filter 113 | , length 114 | , lookup 115 | , map 116 | , mapM 117 | , mapM_ 118 | , notElem 119 | , null 120 | , replicate 121 | , reverse 122 | , span 123 | , take 124 | , takeWhile 125 | , unzip 126 | , zip 127 | , zipWith 128 | ) 129 | import Safe.Plus 130 | import qualified Data.Foldable as F 131 | import qualified Data.HashSet as HashSet 132 | import qualified Data.List as L 133 | import qualified Data.Text as T 134 | import qualified Data.Traversable as Tr 135 | import qualified Prelude as P 136 | 137 | sl :: [a] -> SL a 138 | sl = fromLazyList 139 | 140 | ll :: SL a -> [a] 141 | ll = toLazyList 142 | 143 | -- | 144 | -- >>> null (sl []) 145 | -- True 146 | -- 147 | -- >>> null (sl ["foo"]) 148 | -- False 149 | null :: StrictList a -> Bool 150 | null Nil = True 151 | null _ = False 152 | 153 | -- | 154 | -- prop> not (null xs) ==> isSome (headOpt xs) 155 | headOpt :: StrictList a -> Option a 156 | headOpt Nil = None 157 | headOpt (x :! _) = Some x 158 | 159 | headM :: Monad m => StrictList a -> m a 160 | headM xxs = 161 | case xxs of 162 | Nil -> safeFail "headM of empty strict list." 163 | (x :! _) -> return x 164 | 165 | -- | Safe 'Prelude.tail' function: Returns 'None' for an empty list, 166 | -- 'Some' @x@ for a non-empty list starting with @x@. 167 | tailOpt :: StrictList a -> Option (StrictList a) 168 | tailOpt Nil = None 169 | tailOpt (_ :! xs) = Some xs 170 | 171 | lastOpt :: StrictList a -> Option a 172 | lastOpt = lastM 173 | 174 | lastM :: Monad m => StrictList a -> m a 175 | lastM xxs = 176 | case xxs of 177 | Nil -> safeFail "No last element in strict list." 178 | (x :! Nil) -> return x 179 | (_ :! xs) -> lastM xs 180 | 181 | -- | 182 | -- >>> optionToStrictList (Some "foo") 183 | -- ["foo"] 184 | -- 185 | -- >>> optionToStrictList None 186 | -- [] 187 | optionToStrictList :: Option a -> StrictList a 188 | optionToStrictList None = Nil 189 | optionToStrictList (Some x) = x :! Nil 190 | 191 | -- | 192 | -- >>> maybeToStrictList (Just "bar") 193 | -- ["bar"] 194 | -- 195 | -- >>> maybeToStrictList Nothing 196 | -- [] 197 | maybeToStrictList :: Maybe a -> StrictList a 198 | maybeToStrictList Nothing = Nil 199 | maybeToStrictList (Just x) = x :! Nil 200 | 201 | takeWhile :: (a -> Bool) -> StrictList a -> StrictList a 202 | takeWhile _ Nil = Nil 203 | takeWhile p (x :! xs) 204 | | p x = x :! takeWhile p xs 205 | | otherwise = Nil 206 | 207 | -- | 208 | -- >>> drop 3 (sl [1, 2, 3, 4, 5]) 209 | -- [4,5] 210 | drop :: Int -> StrictList a -> StrictList a 211 | drop _ Nil = Nil 212 | drop n xss@(_ :! xs) 213 | | n <= 0 = xss 214 | | otherwise = drop (n - 1) xs 215 | 216 | -- | 217 | -- 'deleteIdx' @idx@ removes the element at index @idx@. 218 | -- 219 | -- prop> not (null xs) ==> Some (deleteIdx 0 xs) == tailOpt xs 220 | deleteIdx :: Int -> StrictList a -> StrictList a 221 | deleteIdx _ Nil = Nil 222 | deleteIdx idx lst@(x :! xs) = 223 | case idx of 224 | 0 -> 225 | case xs of 226 | Nil -> Nil 227 | l -> l 228 | i -> 229 | if i < 0 230 | then lst 231 | else x :! deleteIdx (i-1) xs 232 | 233 | -- | 'delete' @x@ removes the first occurrence of @x@ from its list argument. 234 | -- NOTE: Implementation copied from Data.List. 235 | delete :: (Eq a) => a -> SL a -> SL a 236 | delete = deleteBy (==) 237 | 238 | -- | The 'deleteBy' function behaves like 'delete', but takes a 239 | -- user-supplied equality predicate. 240 | -- NOTE: Implementation copied from Data.List. 241 | deleteBy :: (a -> a -> Bool) -> a -> SL a -> SL a 242 | deleteBy eq x yys = 243 | case yys of 244 | Nil -> Nil 245 | (y:!ys) -> if x `eq` y then ys else y :! deleteBy eq x ys 246 | 247 | atIdx :: Int -> StrictList a -> Option a 248 | atIdx _ Nil = None 249 | atIdx idx (p :! ps) = 250 | case idx of 251 | 0 -> Some p 252 | i -> 253 | if i < 0 254 | then None 255 | else atIdx (i-1) ps 256 | 257 | dropWhile :: (a -> Bool) -> StrictList a -> StrictList a 258 | dropWhile _ Nil = Nil 259 | dropWhile p (x :! xs) 260 | | p x = dropWhile p xs 261 | | otherwise = x :! xs 262 | 263 | findIndex :: (a -> Bool) -> StrictList a -> Option Int 264 | findIndex _ Nil = None 265 | findIndex p (x :! xs) 266 | | p x = Some 0 267 | | otherwise = (+1) <$> findIndex p xs 268 | 269 | map :: (a -> b) -> StrictList a -> StrictList b 270 | map = fmap 271 | 272 | mapM :: Monad m => (a -> m b) -> StrictList a -> m (StrictList b) 273 | mapM = Tr.mapM 274 | 275 | mapM_ :: Monad m => (a -> m b) -> StrictList a -> m () 276 | mapM_ = F.mapM_ 277 | 278 | -- | Equivalent of 'Prelude.filter' with 'StrictList'. 279 | filter :: (a -> Bool) -> StrictList a -> StrictList a 280 | filter _ Nil = Nil 281 | filter pred (x :! xs) 282 | | pred x = x :! filter pred xs 283 | | otherwise = filter pred xs 284 | 285 | -- | Equivalent of 'Data.Maybe.catMaybes' with 'StrictList'. 286 | catMaybes :: StrictList (Maybe a) -> StrictList a 287 | catMaybes xs = 288 | case xs of 289 | Nil -> Nil 290 | (Nothing :! xs) -> catMaybes xs 291 | (Just x :! xs ) -> x :! catMaybes xs 292 | 293 | -- | Equivalent of 'Data.Maybe.mapMaybe' with 'StrictList'. 294 | mapMaybe :: (a -> Maybe b) -> StrictList a -> StrictList b 295 | mapMaybe f = catMaybes . map f 296 | 297 | -- | Equivalent of 'Data.Maybe.mapMaybe' with 'Option' and 'StrictList'. 298 | -- 299 | -- >>> mapOption (\x -> if even x then Some (x * 2) else None) (sl [1, 2, 3, 4, 5]) 300 | -- [4,8] 301 | mapOption :: (a -> Option b) -> StrictList a -> StrictList b 302 | mapOption f = catOptions . map f 303 | 304 | -- | Equivalent to 'Data.Maybe.catMaybes' with 'Option' and 'StrictList'. 305 | -- 306 | -- >>> catOptions (sl [Some 1, None, Some 2, None, None, Some 3, Some 4]) 307 | -- [1,2,3,4] 308 | catOptions :: StrictList (Option a) -> StrictList a 309 | catOptions xs = 310 | case xs of 311 | Nil -> Nil 312 | (None :! xs) -> catOptions xs 313 | (Some x :! xs) -> x :! catOptions xs 314 | 315 | -- | 316 | -- >>> catOptionsL [Some 1, None, Some 2, None, None, Some 3, Some 4] 317 | -- [1,2,3,4] 318 | catOptionsL :: [Option a] -> StrictList a 319 | catOptionsL xs = 320 | case xs of 321 | [] -> Nil 322 | (None : xs) -> catOptionsL xs 323 | (Some x : xs) -> x :! catOptionsL xs 324 | 325 | -- | 326 | -- >>> take 3 (sl [1, 2, 3, 4, 5, 6, 7]) 327 | -- [1,2,3] 328 | take :: Int -> StrictList a -> StrictList a 329 | take _ Nil = Nil 330 | take n _ | n <= 0 = Nil 331 | take n (x :! xs) = x :! take (n-1) xs 332 | 333 | sort :: (Ord a) => StrictList a -> StrictList a 334 | sort = sortBy compare 335 | 336 | -- | 337 | -- >>> sortOn snd (sl [("foo", 10), ("bar", 1), ("baz", 100)]) 338 | -- [("bar",1),("foo",10),("baz",100)] 339 | sortOn :: (Ord b) => (a -> b) -> StrictList a -> StrictList a 340 | sortOn f = 341 | map snd 342 | . sortBy (comparing fst) 343 | . map (\x -> let y = f x 344 | in y `seq` (y,x)) 345 | 346 | replicate :: Integral i => i -> a -> StrictList a 347 | replicate i a = 348 | case i of 349 | 0 -> Nil 350 | n -> a :! replicate (n-1) a 351 | 352 | -- | 353 | -- prop> reverse (reverse xs) == xs 354 | reverse :: StrictList a -> StrictList a 355 | reverse l = rev l Nil 356 | where 357 | rev xxs !a = 358 | case xxs of 359 | Nil -> a 360 | (x :! xs) -> rev xs (x :! a) 361 | 362 | merge :: Ord a => StrictList a -> StrictList a -> StrictList a 363 | merge = mergeBy compare 364 | 365 | mergeBy :: (a -> a -> Ordering) -> StrictList a -> StrictList a -> StrictList a 366 | mergeBy cmp = go 367 | where 368 | go as@(a :! as') bs@(b :! bs') = 369 | case cmp a b of 370 | LT -> a :! go as' bs 371 | GT -> b :! go as bs' 372 | EQ -> a :! go as' bs' 373 | go Nil bs = bs 374 | go as Nil = as 375 | 376 | sortBy :: (a -> a -> Ordering) -> StrictList a -> StrictList a 377 | sortBy cmp = mergeAll . sequences 378 | where 379 | sequences (a :! (b :! xs)) 380 | | a `cmp` b == GT = descending b (a :! Nil) xs 381 | | otherwise = ascending b (a :!) xs 382 | sequences xs = xs :! Nil 383 | descending a as (b :! bs) 384 | | a `cmp` b == GT = descending b (a :! as) bs 385 | descending a as bs = (a :! as) :! sequences bs 386 | ascending a as (b:!bs) 387 | | a `cmp` b /= GT = ascending b (\ys -> as (a :! ys)) bs 388 | ascending a as bs = as (a :! Nil) :! sequences bs 389 | mergeAll (x :! Nil) = x 390 | mergeAll xs = mergeAll (mergePairs xs) 391 | mergePairs (a :! (b :! xs)) = (merge a b) :! mergePairs xs 392 | mergePairs xs = xs 393 | merge as@(a :! as') bs@(b :! bs') 394 | | a `cmp` b == GT = b :! merge as bs' 395 | | otherwise = a :! merge as' bs 396 | merge Nil bs = bs 397 | merge as Nil = as 398 | 399 | span :: (a -> Bool) -> StrictList a -> (StrictList a, StrictList a) 400 | span _ Nil = (Nil, Nil) 401 | span p xs@(x :! xs') 402 | | p x = let (ys, zs) = span p xs' in (x :! ys, zs) 403 | | otherwise = (Nil, xs) 404 | 405 | break :: (a -> Bool) -> StrictList a -> (StrictList a, StrictList a) 406 | break p = span (not . p) 407 | 408 | concat :: F.Foldable t => t (StrictList a) -> StrictList a 409 | concat = F.fold 410 | 411 | concatSL :: SL (SL a) -> SL a 412 | concatSL = concat 413 | 414 | concatMap :: F.Foldable t => (a -> StrictList b) -> t a -> StrictList b 415 | concatMap = F.foldMap 416 | 417 | concatMapSL :: (a -> StrictList b) -> SL a -> StrictList b 418 | concatMapSL = concatMap 419 | 420 | concatMapM :: (Monad m) => (a -> m (SL b)) -> SL a -> m (SL b) 421 | concatMapM f xs = concat <$> mapM f xs 422 | 423 | any :: (a -> Bool) -> StrictList a -> Bool 424 | any = F.any 425 | 426 | all :: (a -> Bool) -> StrictList a -> Bool 427 | all = F.all 428 | 429 | elem :: Eq a => a -> StrictList a -> Bool 430 | elem = F.elem 431 | 432 | notElem :: Eq a => a -> StrictList a -> Bool 433 | notElem = F.notElem 434 | 435 | find :: (a -> Bool) -> StrictList a -> Maybe a 436 | find = F.find 437 | 438 | zip :: StrictList a -> StrictList b -> StrictList (a :!: b) 439 | zip Nil _ = Nil 440 | zip _ Nil = Nil 441 | zip (x :! xs) (y :! ys) = (x :!: y) :! (zip xs ys) 442 | 443 | zipSL :: StrictList a -> [b] -> StrictList (a :!: b) 444 | zipSL Nil _ = Nil 445 | zipSL _ [] = Nil 446 | zipSL (x :! xs) (y : ys) = (x :!: y) :! (zipSL xs ys) 447 | 448 | zipLS :: [a] -> StrictList b -> StrictList (a :!: b) 449 | zipLS [] _ = Nil 450 | zipLS _ Nil = Nil 451 | zipLS (x : xs) (y :! ys) = (x :!: y) :! (zipLS xs ys) 452 | 453 | zipLL :: [a] -> [b] -> StrictList (a :!: b) 454 | zipLL [] _ = Nil 455 | zipLL _ [] = Nil 456 | zipLL (x : xs) (y : ys) = (x :!: y) :! (zipLL xs ys) 457 | 458 | zipWith :: (a->b->c) -> SL a-> SL b -> SL c 459 | zipWith f (a:!as) (b:!bs) = f a b :! zipWith f as bs 460 | zipWith _ _ _ = Nil 461 | 462 | -- zipWith - left list is lazy, right list is strict 463 | zipWithLS :: (a->b->c) -> [a]-> SL b -> SL c 464 | zipWithLS f (a:as) (b:!bs) = f a b :! zipWithLS f as bs 465 | zipWithLS _ _ _ = Nil 466 | 467 | -- zipWith - left list is strict, right list is lazy 468 | zipWithSL :: (a->b->c) -> SL a-> [b] -> SL c 469 | zipWithSL f (a:!as) (b:bs) = f a b :! zipWithSL f as bs 470 | zipWithSL _ _ _ = Nil 471 | 472 | concatText :: StrictList T.Text -> T.Text 473 | concatText = T.concat . toLazyList 474 | 475 | concatString :: StrictList String -> String 476 | concatString = P.concat . toLazyList 477 | 478 | groupBy :: (a -> a -> Bool) -> StrictList a -> StrictList (StrictList a) 479 | groupBy _ Nil = Nil 480 | groupBy eq (x:!xs) = (x:!ys) :! groupBy eq zs 481 | where (ys,zs) = span (eq x) xs 482 | 483 | intersperse :: a -> StrictList a -> StrictList a 484 | intersperse y = 485 | F.foldr' prepend Nil 486 | where 487 | prepend x xs = 488 | case xs of 489 | Nil -> x :! Nil 490 | _ -> x :! y :! xs 491 | 492 | intercalateText :: T.Text -> StrictList T.Text -> T.Text 493 | intercalateText t = 494 | concatText . intersperse t 495 | 496 | intercalateString :: String -> SL String -> String 497 | intercalateString s = 498 | concatString . intersperse s 499 | 500 | singleton :: a -> StrictList a 501 | singleton x = 502 | x :! Nil 503 | 504 | lookupM' :: (Monad m, Eq a) => (a -> String) -> a -> StrictList (a :!: b) -> m b 505 | lookupM' showA x = fmap snd' . lookupM'' showA (Just . fst') x 506 | 507 | -- | @lookupM'' showKey getKey getValue key list@ searches for @key@ in 508 | -- @list@ using @getKey@ as the key extraction function and @showKey@ to print 509 | -- all available keys when no match is found. 510 | lookupM'' :: (Monad m, Eq k) => (k -> String) -> (a -> Maybe k) -> k -> StrictList a -> m a 511 | lookupM'' showKey getKey wantedK list = loop list 512 | where 513 | loop xxs = 514 | case xxs of 515 | Nil -> 516 | let keys = ll $ mapMaybe getKey list 517 | keyCount = P.length keys 518 | count = P.length list 519 | in safeFail $ 520 | "Didn't find " ++ showKey wantedK ++ " in the list with these keys [" 521 | ++ L.intercalate ", " (fmap showKey keys) ++ "]. " ++ 522 | if keyCount == count 523 | then "" 524 | else ("Only " ++ show keyCount ++ "/" ++ show count ++ " entries had a key.") 525 | (x@(getKey -> Just curK) :! xs) 526 | | wantedK == curK -> return x 527 | | otherwise -> loop xs 528 | _ :! xs -> loop xs 529 | 530 | lookupM :: (Monad m, Show a, Eq a) => a -> StrictList (a :!: b) -> m b 531 | lookupM = lookupM' show 532 | 533 | lookup :: Eq a => a -> StrictList (a :!: b) -> Option b 534 | lookup = lookupM' (const "fail in Option is None") 535 | 536 | insert :: Ord a => a -> SL a -> SL a 537 | insert = insertBy compare 538 | 539 | insertBy :: (a -> a -> Ordering) -> a -> SL a -> SL a 540 | insertBy cmp x yss = 541 | case yss of 542 | Nil -> x :! Nil 543 | y:!ys -> 544 | case cmp x y of 545 | GT -> y :! insertBy cmp x ys 546 | _ -> x :! yss 547 | 548 | partition :: (a -> Bool) -> SL a -> (SL a, SL a) 549 | partition p = 550 | F.foldr (select p) (Nil, Nil) 551 | where 552 | select :: (a -> Bool) -> a -> (SL a, SL a) -> (SL a, SL a) 553 | select p x (ts, fs) 554 | | p x = (x :! ts, fs) 555 | | otherwise = (ts, x :! fs) 556 | 557 | dropWhileEnd :: (a -> Bool) -> SL a -> SL a 558 | dropWhileEnd p = 559 | F.foldr (\x xs -> if p x && null xs then Nil else x :! xs) Nil 560 | 561 | maximumM :: (Ord a, Monad m) => SL a -> m a 562 | maximumM xxs = 563 | case xxs of 564 | Nil -> safeFail "Empty list doesn't have a maximum." 565 | (x :! xs) -> return $! loop x xs 566 | where 567 | loop x yys = 568 | case yys of 569 | Nil -> x 570 | (y :! ys) -> loop (max x y) ys 571 | 572 | mconcatSL :: Monoid a => SL a -> a 573 | mconcatSL = F.foldr mappend mempty 574 | 575 | stripPrefix :: Eq a => SL a -> SL a -> Maybe (SL a) 576 | stripPrefix Nil ys = Just ys 577 | stripPrefix (x :! xs) (y :! ys) | x == y = stripPrefix xs ys 578 | stripPrefix _ _ = Nothing 579 | 580 | stripSuffix :: Eq a => SL a -> SL a -> Maybe (SL a) 581 | stripSuffix suffix xs = fmap reverse (stripPrefix (reverse suffix) (reverse xs)) 582 | 583 | -- unzip strict list of strict tuples to strict lists of strict tuples 584 | unzip :: SL (a :!: b) -> (SL a :!: SL b) 585 | unzip = F.foldr (\(a :!: b) (as :!: bs) -> (a:!as :!: b:!bs)) (Nil :!: Nil) 586 | 587 | -- unzip lazy list of lazy tuples to strict lists of strict tuples 588 | unzipLL :: [(a,b)] -> (SL a :!: SL b) 589 | unzipLL = F.foldr (\(a,b) (as :!: bs) -> (a:!as :!: b:!bs)) (Nil :!: Nil) 590 | 591 | -- unzip lazy list of strict tuples to strict lists of strict tuples 592 | unzipL :: [(a:!:b)] -> (SL a :!: SL b) 593 | unzipL = F.foldr (\(a:!:b) (as :!: bs) -> (a:!as :!: b:!bs)) (Nil :!: Nil) 594 | 595 | -- | Appends an element to the end of this list. This is really inefficient because the 596 | -- whole list needs to be copied. Use at your own risk. 597 | snoc :: SL a -> a -> SL a 598 | snoc xxs y = 599 | case xxs of 600 | Nil -> y :! Nil 601 | x :! xs -> x :! snoc xs y 602 | 603 | -- NOTE: copied from Data.List 604 | transpose :: SL (SL a) -> SL (SL a) 605 | transpose xxs = 606 | case xxs of 607 | Nil -> Nil 608 | (Nil :! ys) -> transpose ys 609 | ((x:!xs) :! xss) -> (x :! [h | (h:!_) <- xss]) :! transpose (xs :! [ t | (_:!t) <- xss]) 610 | 611 | (\!\) :: (Eq a) => SL a -> SL a -> SL a 612 | (\!\) = F.foldl (flip delete) 613 | 614 | nub :: (Eq a, Hashable a) => SL a -> SL a 615 | nub = nub' HashSet.empty 616 | where 617 | nub' acc xxs = 618 | case xxs of 619 | Nil -> Nil 620 | x :! xs 621 | | x `HashSet.member` acc -> nub' acc xs 622 | | otherwise -> x :! nub' (HashSet.insert x acc) xs 623 | -------------------------------------------------------------------------------- /strict-data/src/Data/StrictList/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE MonadComprehensions #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | module Data.StrictList.Types where 10 | 11 | import Control.Applicative 12 | import Control.DeepSeq 13 | import Control.Monad hiding (forM_, mapM, mapM_) 14 | import Data.Aeson 15 | import Data.Data 16 | import Data.Hashable (Hashable) 17 | import Data.Monoid 18 | import Data.Traversable hiding (mapM) 19 | import GHC.Exts 20 | import GHC.Generics (Generic) 21 | import Prelude (Eq(..), Ord(..), Show(..), (.), (+), Bool) 22 | import Test.QuickCheck 23 | import Text.Read 24 | import qualified Control.Monad.Fail 25 | import qualified Data.Foldable as F 26 | 27 | type SL = StrictList 28 | 29 | data StrictList a 30 | = Nil 31 | | !a :! !(StrictList a) 32 | deriving (Eq,Ord,Functor,F.Foldable,Traversable,Typeable,Generic,Data) 33 | 34 | instance Read a => Read (StrictList a) where 35 | readPrec = fromLazyList <$> readPrec 36 | 37 | instance Show a => Show (StrictList a) where 38 | showsPrec n xs = showsPrec n (toLazyList xs) 39 | 40 | infixr 5 +!+ 41 | infixr 5 :! 42 | 43 | (+!+) :: StrictList a -> StrictList a -> StrictList a 44 | (+!+) Nil ys = ys 45 | (+!+) (x :! xs) ys = x :! (xs +!+ ys) 46 | 47 | instance Applicative StrictList where 48 | pure = return 49 | (<*>) = ap 50 | 51 | instance Alternative StrictList where 52 | empty = Nil 53 | (<|>) = (+!+) 54 | 55 | instance Control.Monad.Fail.MonadFail StrictList where 56 | fail _ = Nil 57 | 58 | instance Monad StrictList where 59 | return = (:! Nil) 60 | (>>=) xs f = F.asum (fmap f xs) 61 | fail = Control.Monad.Fail.fail 62 | 63 | instance Arbitrary a => Arbitrary (StrictList a) where 64 | arbitrary = 65 | do v <- arbitrary 66 | return (fromLazyList v) 67 | 68 | instance Monoid (StrictList a) where 69 | mempty = Nil 70 | mappend = (+!+) 71 | 72 | instance Hashable a => Hashable (StrictList a) 73 | 74 | instance ToJSON a => ToJSON (StrictList a) where 75 | toJSON = toJSON . toLazyList 76 | 77 | instance FromJSON a => FromJSON (StrictList a) where 78 | parseJSON = fmap fromLazyList . parseJSON 79 | 80 | instance NFData a => NFData (StrictList a) 81 | 82 | instance IsList (StrictList a) where 83 | type Item (StrictList a) = a 84 | fromList = fromLazyList 85 | toList = toLazyList 86 | 87 | length :: StrictList a -> Int 88 | length xxs = 89 | case xxs of 90 | _ :! xs -> 1 + length xs 91 | Nil -> 0 92 | 93 | fromLazyList :: [a] -> StrictList a 94 | fromLazyList [] = Nil 95 | fromLazyList (x : xs) = x :! fromLazyList xs 96 | 97 | toLazyList :: StrictList a -> [a] 98 | toLazyList Nil = [] 99 | toLazyList (x :! xs) = x : toLazyList xs 100 | 101 | prop_StrictListOrd :: [Int] -> [Int] -> Bool 102 | prop_StrictListOrd l1 l2 = 103 | let l1' = fromLazyList l1 104 | l2' = fromLazyList l2 105 | in compare l1 l2 == compare l1' l2' 106 | -------------------------------------------------------------------------------- /strict-data/src/Data/StrictTuple.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | module Data.StrictTuple 6 | ( module Data.Strict.Tuple 7 | , toLazyTuple 8 | , fromLazyTuple 9 | , fst', snd' 10 | , uncurry' 11 | , first, second 12 | , swap, swap' 13 | , fst3, snd3, thr3 14 | , fst3', snd3', thr3' 15 | ) 16 | where 17 | 18 | import Control.DeepSeq (NFData(..)) 19 | import Data.Aeson 20 | import Data.Data 21 | import Data.Hashable 22 | import Data.Strict.Tuple hiding (fst, snd) 23 | import Data.Tuple 24 | import Test.QuickCheck 25 | import qualified Data.Strict.Tuple 26 | 27 | deriving instance Typeable Pair 28 | deriving instance (Data a, Data b) => Data (Pair a b) 29 | 30 | instance (Hashable a, Hashable b) => Hashable (Pair a b) where 31 | hashWithSalt s (a :!: b) = hashWithSalt s a `hashWithSalt` b 32 | 33 | instance (NFData a, NFData b) => NFData (Pair a b) where 34 | rnf (a :!: b) = rnf a `seq` rnf b 35 | 36 | instance (Monoid a, Monoid b) => Monoid (Pair a b) where 37 | mempty = mempty :!: mempty 38 | (a1 :!: b1) `mappend` (a2 :!: b2) = a1 `mappend` a2 :!: b1 `mappend` b2 39 | 40 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Pair a b) where 41 | arbitrary = (:!:) <$> arbitrary <*> arbitrary 42 | 43 | instance (ToJSON a, ToJSON b) => ToJSON (Pair a b) where 44 | toJSON = toJSON . toLazyTuple 45 | 46 | instance (FromJSON a, FromJSON b) => FromJSON (Pair a b) where 47 | parseJSON = fmap fromLazyTuple . parseJSON 48 | 49 | toLazyTuple :: a :!: b -> (a, b) 50 | toLazyTuple (x :!: y) = (x, y) 51 | 52 | fromLazyTuple :: (a, b) -> a :!: b 53 | fromLazyTuple (x, y) = x :!: y 54 | 55 | fst' :: Pair a b -> a 56 | fst' = Data.Strict.Tuple.fst 57 | 58 | snd' :: Pair a b -> b 59 | snd' = Data.Strict.Tuple.snd 60 | 61 | uncurry' :: (a -> b -> c) -> Pair a b -> c 62 | uncurry' = Data.Strict.Tuple.uncurry 63 | 64 | first :: (a -> b) -> (a :!: c) -> (b :!: c) 65 | first f (a :!: c) = f a :!: c 66 | 67 | second :: (b -> c) -> (a :!: b) -> (a :!: c) 68 | second f (a :!: b) = a :!: f b 69 | 70 | swap' :: (a :!: b) -> (b :!: a) 71 | swap' (x :!: y) = y :!: x 72 | 73 | fst3 :: (a, b, c) -> a 74 | fst3 (x, _, _) = x 75 | 76 | snd3 :: (a, b, c) -> b 77 | snd3 (_, x, _) = x 78 | 79 | thr3 :: (a, b, c) -> c 80 | thr3 (_, _, x) = x 81 | 82 | fst3' :: (a :!: b :!: c) -> a 83 | fst3' (x :!: _ :!: _) = x 84 | 85 | snd3' :: (a :!: b :!: c) -> b 86 | snd3' (_ :!: x :!: _) = x 87 | 88 | thr3' :: (a :!: b :!: c) -> c 89 | thr3' (_ :!: _ :!: x) = x 90 | -------------------------------------------------------------------------------- /strict-data/src/Data/StrictVector.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | module Data.StrictVector 10 | ( module Data.Vector.Generic 11 | , Vector 12 | , null, length, (!), (!?), head, last 13 | , fromList, fromListN, toList, empty, singleton 14 | , generate, generateM 15 | , catMaybes, mapMaybe, lastMay, toHashSet 16 | , lookAround 17 | , dropWhileEnd 18 | , dropWhileLookingAround 19 | , fromSL 20 | , imapM, binarySearchL, binarySearchR 21 | , sort 22 | , sortBy 23 | , sortOn 24 | , groupBy 25 | , groupOn 26 | , toSL 27 | , uncons 28 | , updateVector, updateVectorWith 29 | , unfoldrM, unfoldrNM 30 | , theOnlyOne 31 | ) where 32 | 33 | import Data.Option 34 | import Data.StrictList (SL, toLazyList, fromLazyList) 35 | -- import qualified Cpm.Util.List as L 36 | import qualified Data.StrictVector.Mutable as VM 37 | 38 | import Control.DeepSeq (NFData) 39 | import Control.Monad 40 | import Data.Aeson (ToJSON, FromJSON(..)) 41 | import Data.Bits (shiftR) 42 | import Data.Data 43 | import Data.HashSet (HashSet) 44 | import Data.Hashable (Hashable(..)) 45 | import Data.Vector.Generic hiding 46 | ( Vector, fromList, fromListN, toList, empty, singleton, null, length ,(!), (!?), head, last 47 | , imapM, generate, generateM, unfoldrNM, unfoldrM, mapMaybe) 48 | import Prelude hiding 49 | ( map, drop, dropWhile, concatMap, length, zip3, mapM, null, (++), replicate, head, last) 50 | import Safe.Plus 51 | import Test.QuickCheck (Arbitrary(..)) 52 | import Text.Read 53 | import qualified Control.Applicative as A 54 | import qualified Control.Monad.Fail 55 | import qualified Data.HashSet as HashSet 56 | import qualified Data.Vector as V 57 | import qualified Data.Vector.Algorithms.Intro as VA (sortBy, sort) 58 | import qualified Data.Vector.Fusion.Bundle.Monadic as VFM 59 | import qualified Data.Vector.Generic as VG 60 | import qualified GHC.Exts as Exts 61 | 62 | newtype Vector a = Vector (V.Vector a) 63 | deriving (Eq, Ord, NFData, ToJSON, Monoid, Foldable, Data, Typeable) 64 | 65 | type instance VG.Mutable Vector = VM.MVector 66 | 67 | instance VG.Vector Vector a where 68 | basicUnsafeFreeze (VM.MVector v) = fmap Vector (basicUnsafeFreeze v) 69 | basicUnsafeThaw (Vector v) = fmap VM.MVector (basicUnsafeThaw v) 70 | basicLength (Vector v) = basicLength v 71 | basicUnsafeSlice n m (Vector v) = Vector (basicUnsafeSlice n m v) 72 | basicUnsafeIndexM (Vector v) = basicUnsafeIndexM v 73 | basicUnsafeCopy (VM.MVector v1) (Vector v2) = basicUnsafeCopy v1 v2 74 | elemseq _ = seq 75 | 76 | instance Show a => Show (Vector a) where 77 | showsPrec = VG.showsPrec 78 | 79 | instance Read a => Read (Vector a) where 80 | readPrec = VG.readPrec 81 | readListPrec = readListPrecDefault 82 | 83 | instance (Hashable a) => Hashable (Vector a) where 84 | hashWithSalt = hashVectorWithSalt 85 | 86 | instance Arbitrary a => Arbitrary (Vector a) where 87 | arbitrary = VG.fromList <$> arbitrary 88 | 89 | instance Functor Vector where 90 | {-# INLINE fmap #-} 91 | fmap = VG.map 92 | 93 | instance Control.Monad.Fail.MonadFail Vector where 94 | {-# INLINE fail #-} 95 | fail _ = VG.empty 96 | 97 | instance Monad Vector where 98 | {-# INLINE return #-} 99 | return = VG.singleton 100 | {-# INLINE (>>=) #-} 101 | (>>=) = flip VG.concatMap 102 | {-# INLINE fail #-} 103 | fail = safeFail 104 | 105 | instance MonadPlus Vector where 106 | {-# INLINE mzero #-} 107 | mzero = VG.empty 108 | {-# INLINE mplus #-} 109 | mplus = (VG.++) 110 | 111 | instance Applicative Vector where 112 | {-# INLINE pure #-} 113 | pure = VG.singleton 114 | {-# INLINE (<*>) #-} 115 | (<*>) = ap 116 | 117 | instance A.Alternative Vector where 118 | {-# INLINE empty #-} 119 | empty = VG.empty 120 | {-# INLINE (<|>) #-} 121 | (<|>) = (VG.++) 122 | 123 | instance Traversable Vector where 124 | {-# INLINE traverse #-} 125 | traverse f xs = fromList <$> traverse f (toList xs) 126 | {-# INLINE mapM #-} 127 | mapM = VG.mapM 128 | {-# INLINE sequence #-} 129 | sequence = VG.sequence 130 | 131 | instance Exts.IsList (Vector a) where 132 | type Item (Vector a) = a 133 | fromList = fromList 134 | fromListN = fromListN 135 | toList = toList 136 | 137 | instance FromJSON a => FromJSON (Vector a) where 138 | parseJSON x = (convert :: V.Vector a -> Vector a) <$> parseJSON x 139 | 140 | -- | /O(1)/ Yield the length of the vector. 141 | length :: Vector a -> Int 142 | {-# INLINE length #-} 143 | length = VG.length 144 | 145 | -- | /O(1)/ Test whether a vector if empty 146 | null :: Vector a -> Bool 147 | {-# INLINE null #-} 148 | null = VG.null 149 | 150 | -- | O(1) Indexing 151 | (!) :: Vector a -> Int -> a 152 | {-# INLINE (!) #-} 153 | (!) = (VG.!) 154 | 155 | -- | O(1) Safe indexing 156 | (!?) :: Vector a -> Int -> Maybe a 157 | {-# INLINE (!?) #-} 158 | (!?) = (VG.!?) 159 | 160 | -- | /O(1)/ First element 161 | head :: Vector a -> a 162 | {-# INLINE head #-} 163 | head = VG.head 164 | 165 | -- | /O(1)/ Last element 166 | last :: Vector a -> a 167 | {-# INLINE last #-} 168 | last = VG.last 169 | 170 | fromList :: [a] -> Vector a 171 | {-# INLINE fromList #-} 172 | fromList = VG.fromList 173 | 174 | fromListN :: Int -> [a] -> Vector a 175 | {-# INLINE fromListN #-} 176 | fromListN = VG.fromListN 177 | 178 | toList :: Vector a -> [a] 179 | {-# INLINE toList #-} 180 | toList = VG.toList 181 | 182 | singleton :: a -> Vector a 183 | {-# INLINE singleton #-} 184 | singleton = VG.singleton 185 | 186 | empty :: Vector a 187 | {-# INLINE empty #-} 188 | empty = VG.empty 189 | 190 | generate :: Int -> (Int -> a) -> Vector a 191 | {-# INLINE generate #-} 192 | generate = VG.generate 193 | 194 | generateM :: Monad m => Int -> (Int -> m a) -> m (Vector a) 195 | {-# INLINE generateM #-} 196 | generateM = VG.generateM 197 | 198 | fromSL :: SL a -> Vector a 199 | {-# INLINE fromSL #-} 200 | fromSL = VG.fromList . toLazyList 201 | 202 | toSL :: Vector a -> SL a 203 | {-# INLINE toSL #-} 204 | toSL = fromLazyList . toList 205 | 206 | {-# INLINABLE hashVectorWithSalt #-} 207 | hashVectorWithSalt :: Hashable a => Int -> Vector a -> Int 208 | hashVectorWithSalt salt v = foldl' hashWithSalt salt v 209 | 210 | {-# INLINABLE mapMaybe #-} 211 | mapMaybe :: (a -> Maybe b) -> Vector a -> Vector b 212 | mapMaybe f = catMaybes . map f 213 | 214 | {-# INLINABLE catMaybes #-} 215 | catMaybes :: Vector (Maybe a) -> Vector a 216 | catMaybes = concatMap maybeToVector 217 | 218 | {-# INLINABLE maybeToVector #-} 219 | maybeToVector :: Maybe a -> Vector a 220 | maybeToVector Nothing = VG.empty 221 | maybeToVector (Just x) = VG.singleton x 222 | 223 | {-# INLINABLE lastMay #-} 224 | lastMay :: Vector a -> Maybe a 225 | lastMay vec = 226 | vec !? ((length vec) - 1) 227 | 228 | uncons :: Vector a -> Option (a, Vector a) 229 | uncons v | null v = None 230 | | otherwise = Some (unsafeHead v, drop 1 v) 231 | 232 | -- | Returns `Just` the only element of the vector if there is exactly 233 | -- one element or `Nothing` otherwise. 234 | theOnlyOne :: Vector a -> Maybe a 235 | theOnlyOne xs 236 | | length xs /= 1 = Nothing 237 | | otherwise = xs !? 0 238 | 239 | {-# INLINABLE lookAround #-} 240 | lookAround :: Vector a -> Vector (Maybe a, a, Maybe a) 241 | lookAround v = zip3 lookBehind v lookAhead 242 | where 243 | lookBehind = Nothing `cons` map Just v 244 | lookAhead = drop 1 (map Just v) `snoc` Nothing 245 | 246 | {-# INLINABLE toHashSet #-} 247 | toHashSet :: (Eq a, Hashable a) => Vector a -> HashSet a 248 | toHashSet = foldl' (\set elem -> HashSet.insert elem set) HashSet.empty 249 | 250 | dropWhileLookingAround :: (Maybe a -> a -> Maybe a -> Bool) -> Vector a -> Vector a 251 | dropWhileLookingAround f = map (\(_, v, _) -> v) . dropWhile (\(x,y,z) -> f x y z) . lookAround 252 | 253 | dropWhileEnd :: (a -> Bool) -> Vector a -> Vector a 254 | dropWhileEnd pred v = 255 | case pred `fmap` (v !? (length v - 1)) of 256 | Nothing -> v 257 | Just False -> v 258 | Just True -> 259 | let toDelete count = 260 | case pred `fmap` (v !? (length v - count - 1)) of 261 | Nothing -> count 262 | Just False -> count 263 | Just True -> toDelete (count + 1) 264 | in VG.take (length v - toDelete 1) v 265 | 266 | imapM :: Monad m => (Int -> a -> m b) -> Vector a -> m (Vector b) 267 | {-# INLINE imapM #-} 268 | imapM = VG.imapM 269 | 270 | binarySearchL :: (e -> Ordering) -> Vector e -> Int 271 | binarySearchL cmp vec = loop 0 (length vec) 272 | where 273 | loop !l !u 274 | | u <= l = l 275 | | otherwise = 276 | let k = (u + l) `shiftR` 1 277 | in case cmp (vec ! k) of 278 | LT -> loop (k+1) u 279 | _ -> loop l k 280 | 281 | binarySearchR :: (e -> Ordering) -> Vector e -> Int 282 | binarySearchR cmp vec = loop 0 (length vec) 283 | where 284 | loop !l !u 285 | | u <= l = l 286 | | otherwise = 287 | let k = (u + l) `shiftR` 1 288 | in case cmp (vec ! k) of 289 | GT -> loop l k 290 | _ -> loop (k+1) u 291 | 292 | sortOn :: Ord b => (a -> b) -> Vector a -> Vector a 293 | sortOn f = sortBy (\x y -> compare (f x) (f y)) 294 | 295 | sortBy :: (a -> a -> Ordering) -> Vector a -> Vector a 296 | sortBy comp v = 297 | modify (VA.sortBy comp) v 298 | 299 | sort :: Ord a => Vector a -> Vector a 300 | sort v = modify VA.sort v 301 | 302 | groupBy :: (a -> a -> Bool) -> Vector a -> Vector (Vector a) 303 | groupBy eq xs = unfoldrN (VG.length xs) next xs 304 | where 305 | next ys 306 | | VG.null ys = Nothing 307 | | otherwise = 308 | let y = VG.unsafeHead ys 309 | ys' = VG.unsafeTail ys 310 | (l1,l2) = VG.span (eq y) ys' 311 | in Just (y `VG.cons` l1, l2) 312 | 313 | groupOn :: Eq b => (a -> b) -> Vector a -> Vector (b, (Vector a)) 314 | groupOn proj xs = unfoldrN (VG.length xs) next xs 315 | where 316 | next ys 317 | | VG.null ys = Nothing 318 | | otherwise = 319 | let y = VG.unsafeHead ys 320 | z = proj y 321 | ys' = VG.unsafeTail ys 322 | (l1,l2) = VG.span (\x -> proj x == z) ys' 323 | in Just ((z , y `VG.cons` l1), l2) 324 | 325 | unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> m (Vector a) 326 | unfoldrM f s = unstreamM (VFM.unfoldrM f s) 327 | 328 | unfoldrNM :: Monad m => Int -> (s -> m (Maybe (a, s))) -> s -> m (Vector a) 329 | unfoldrNM n f s = unstreamM (VFM.unfoldrNM n f s) 330 | 331 | -- | Copied from Data.Vector.Generic as it isn't exported there 332 | unstreamM :: (Monad m) => VFM.Bundle m u a -> m (Vector a) 333 | {-# INLINE unstreamM #-} 334 | unstreamM s = 335 | do xs <- VFM.toList s 336 | return $ unstream $ VFM.unsafeFromList (VFM.size s) xs 337 | 338 | updateVector :: Int -> a -> a -> Vector a -> Vector a 339 | updateVector comp def val vect = updateVectorWith comp def (const val) vect 340 | 341 | updateVectorWith :: Int -> a -> (a -> a) -> Vector a -> Vector a 342 | updateVectorWith comp def val vect = 343 | let vect' = 344 | if comp >= length vect 345 | then vect ++ replicate (comp - (length vect) + 1) def 346 | else vect 347 | in vect' // [(comp, val (vect' ! comp))] 348 | -------------------------------------------------------------------------------- /strict-data/src/Data/StrictVector/Mutable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Data.StrictVector.Mutable 6 | ( module Data.Vector.Generic.Mutable 7 | , MVector(..) 8 | , IOVector, STVector 9 | ) 10 | where 11 | 12 | import Control.Monad.ST (RealWorld) 13 | import Data.Vector.Generic.Mutable hiding (MVector) 14 | import qualified Data.Vector.Generic.Mutable as VGM 15 | import qualified Data.Vector.Mutable as VM 16 | 17 | -- | 'MVector' is a strict wrapper around "Data.Vector.Mutable"'s 'Data.Vector.Mutable.MVector' 18 | newtype MVector s a = MVector (VM.MVector s a) 19 | 20 | instance VGM.MVector MVector a where 21 | basicLength (MVector v) = VGM.basicLength v 22 | basicUnsafeSlice n m (MVector v) = MVector $ VGM.basicUnsafeSlice n m v 23 | basicOverlaps (MVector v1) (MVector v2) = VGM.basicOverlaps v1 v2 24 | basicUnsafeNew n = fmap MVector (VGM.basicUnsafeNew n) 25 | basicInitialize (MVector v) = basicInitialize v 26 | basicUnsafeReplicate n x = x `seq` fmap MVector (VGM.basicUnsafeReplicate n x) 27 | basicUnsafeRead (MVector v) n = VGM.basicUnsafeRead v n 28 | basicUnsafeWrite (MVector v) n x = x `seq` VGM.basicUnsafeWrite v n x 29 | basicClear (MVector v) = VGM.basicClear v 30 | basicSet (MVector v) x = x `seq` VGM.basicSet v x 31 | basicUnsafeCopy (MVector v1) (MVector v2) = VGM.basicUnsafeCopy v1 v2 32 | basicUnsafeMove (MVector v1) (MVector v2) = VGM.basicUnsafeMove v1 v2 33 | basicUnsafeGrow (MVector v) n = fmap MVector (VGM.basicUnsafeGrow v n) 34 | 35 | type IOVector = MVector RealWorld 36 | type STVector s = MVector s 37 | 38 | -------------------------------------------------------------------------------- /strict-data/strict-data.cabal: -------------------------------------------------------------------------------- 1 | name: strict-data 2 | version: 0.2.0.2 3 | synopsis: A collection of commonly used strict data structures 4 | description: A collection of commonly used strict data structures 5 | homepage: https://github.com/factisresearch/opensource#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Alexander Thiemann 9 | , factis research GmbH 10 | maintainer: mail@athiemann.net 11 | copyright: 2016 Alexander Thiemann 12 | , 2017 factis research GmbH 13 | category: Data 14 | build-type: Simple 15 | extra-source-files: 16 | README.md 17 | cabal-version: >=1.10 18 | 19 | library 20 | hs-source-dirs: src 21 | exposed-modules: Data.Choice 22 | , Data.Fail 23 | , Data.Option 24 | , Data.StrictList 25 | , Data.StrictTuple 26 | , Data.StrictVector 27 | , Data.StrictVector.Mutable 28 | , Data.Map.Ordered 29 | , Data.Map.Unordered 30 | other-modules: Data.Fail.Types 31 | , Data.StrictList.Types 32 | build-depends: base >= 4.7 && < 5 33 | , QuickCheck 34 | , aeson 35 | , deepseq 36 | , exceptions 37 | , fail 38 | , hashable 39 | , monad-control 40 | , mtl 41 | , pretty 42 | , resourcet 43 | , strict 44 | , text 45 | , transformers 46 | , transformers-base 47 | , containers >= 0.5 48 | , unordered-containers 49 | , util-plus 50 | , vector 51 | , vector-algorithms 52 | default-language: Haskell2010 53 | ghc-options: -Wall -Wdodgy-imports 54 | 55 | test-suite strict-data-test 56 | type: exitcode-stdio-1.0 57 | hs-source-dirs: test 58 | main-is: Spec.hs 59 | other-modules: Fail 60 | , Option 61 | , StrictList 62 | , StrictVector 63 | , StrictVector.Mutable 64 | , Data.Map.OrderedSpec 65 | build-depends: base >= 4.7 && < 5 66 | , strict-data 67 | , HTF 68 | , vector 69 | , deepseq 70 | , hashable 71 | , containers 72 | ghc-options: -Wall 73 | default-language: Haskell2010 74 | 75 | test-suite strict-data-doctest 76 | type: exitcode-stdio-1.0 77 | hs-source-dirs: test 78 | main-is: Doc.hs 79 | build-depends: base >= 4.7 && < 5 80 | , doctest 81 | default-language: Haskell2010 82 | 83 | source-repository head 84 | type: git 85 | location: https://github.com/factisresearch/opensource.git 86 | -------------------------------------------------------------------------------- /strict-data/test/Data/Map/OrderedSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 5 | module Data.Map.OrderedSpec 6 | ( htf_thisModulesTests 7 | ) 8 | where 9 | 10 | import Data.Map.Ordered 11 | 12 | import Data.Traversable 13 | import Prelude hiding (map, lookup, null, filter) 14 | import System.IO.Unsafe (unsafePerformIO) 15 | import Test.Framework 16 | import qualified Control.Exception as E 17 | 18 | newtype OSMapInt = OSMapInt (OSMap Int Int) 19 | deriving (Eq, Show) 20 | 21 | bottom :: a 22 | bottom = undefined 23 | 24 | bottomInt :: Int 25 | bottomInt = bottom 26 | 27 | -- | A modified variant of 'isBottomTimeOut' that lives in the 'IO' monad. 28 | -- (Taken from ChasingBottoms) 29 | isBottom :: a -> Bool 30 | isBottom f = 31 | unsafePerformIO $! 32 | E.evaluate (f `seq` False) `E.catches` 33 | [ E.Handler (\(_ :: E.ArrayException) -> return True) 34 | , E.Handler (\(_ :: E.ErrorCall) -> return True) 35 | , E.Handler (\(_ :: E.NoMethodError) -> return True) 36 | , E.Handler (\(_ :: E.NonTermination) -> return True) 37 | , E.Handler (\(_ :: E.PatternMatchFail) -> return True) 38 | , E.Handler (\(_ :: E.RecConError) -> return True) 39 | , E.Handler (\(_ :: E.RecSelError) -> return True) 40 | , E.Handler (\(_ :: E.RecUpdError) -> return True) 41 | ] 42 | 43 | keyValueByIndex :: Int -> OSMap Int Int -> (Int, Int) 44 | keyValueByIndex i m = 45 | let n = size m 46 | in toList m !! (i `mod` n) 47 | 48 | valueByIndex :: Int -> OSMap Int Int -> Int 49 | valueByIndex i m = snd (keyValueByIndex i m) 50 | 51 | keyByIndex :: Int -> OSMap Int Int -> Int 52 | keyByIndex i m = fst (keyValueByIndex i m) 53 | 54 | instance Arbitrary OSMapInt where 55 | arbitrary = 56 | do l <- arbitrary 57 | return $ OSMapInt $ fromList l 58 | 59 | prop_insertStrictKey :: OSMapInt -> Int -> Bool 60 | prop_insertStrictKey (OSMapInt m) v = 61 | isBottom (insert bottom v m) 62 | 63 | prop_insertStrictValue :: OSMapInt -> Int -> Bool 64 | prop_insertStrictValue (OSMapInt m) k = 65 | isBottom (insert k bottom m) 66 | 67 | prop_deleteStrict :: OSMapInt -> Bool 68 | prop_deleteStrict (OSMapInt m) = isBottom (delete bottom m) 69 | 70 | prop_mapStrict :: OSMapInt -> Int -> Property 71 | prop_mapStrict (OSMapInt m) i = 72 | not (null m) ==> 73 | isBottom $ map (\x -> if x == value then bottom else x) m 74 | where 75 | value = valueByIndex i m 76 | 77 | prop_singletonStrictKey :: Int -> Bool 78 | prop_singletonStrictKey v = 79 | isBottom $ singleton bottomInt v 80 | 81 | prop_singletonStrictValue :: Int -> Bool 82 | prop_singletonStrictValue k = 83 | isBottom $ singleton k bottom 84 | 85 | prop_insertWithStrictKey :: OSMapInt -> Int -> Bool 86 | prop_insertWithStrictKey (OSMapInt m) v = 87 | isBottom $ insertWith (\_ _ -> 0) bottom v m 88 | 89 | prop_insertWithStrictValue1 :: OSMapInt -> Int -> Bool 90 | prop_insertWithStrictValue1 (OSMapInt m) k = 91 | isBottom $ insertWith (\_ _ -> 0) k bottom m 92 | 93 | prop_insertWithStrictValue2 :: OSMapInt -> Int -> Int -> Property 94 | prop_insertWithStrictValue2 (OSMapInt m) v i = 95 | not (null m) ==> 96 | isBottom $ insertWith (\_ old -> if old == value then bottom else v) key v m 97 | where 98 | (key, value) = keyValueByIndex i m 99 | 100 | prop_unionStrictLeft :: OSMapInt -> Bool 101 | prop_unionStrictLeft (OSMapInt m) = 102 | isBottom $ union bottom m 103 | 104 | prop_unionStrictRight :: OSMapInt -> Bool 105 | prop_unionStrictRight (OSMapInt m) = 106 | isBottom $ union m bottom 107 | 108 | prop_differenceStrictLeft :: OSMapInt -> Bool 109 | prop_differenceStrictLeft (OSMapInt m) = 110 | isBottom $ difference bottom m 111 | 112 | prop_differenceStrictRight :: OSMapInt -> Property 113 | prop_differenceStrictRight (OSMapInt m) = 114 | not (null m) ==> 115 | isBottom $ difference m bottom 116 | 117 | prop_intersectionStrictLeft :: OSMapInt -> Bool 118 | prop_intersectionStrictLeft (OSMapInt m) = 119 | isBottom $ intersection bottom m 120 | 121 | prop_intersectionStrictRight :: OSMapInt -> Property 122 | prop_intersectionStrictRight (OSMapInt m) = 123 | not (null m) ==> 124 | isBottom $ intersection m bottom 125 | 126 | prop_insertLookupWithKeyStrictKey :: OSMapInt -> Int -> Bool 127 | prop_insertLookupWithKeyStrictKey (OSMapInt m) v = 128 | isBottom $ snd $ insertLookupWithKey (\_ _ _ -> 0) bottom v m 129 | 130 | prop_insertLookupWithKeyStrictValue1 :: OSMapInt -> Int -> Bool 131 | prop_insertLookupWithKeyStrictValue1 (OSMapInt m) k = 132 | isBottom $ snd $ insertLookupWithKey (\_ _ _ -> 0) k bottom m 133 | 134 | prop_insertLookupWithKeyStrictValue2 :: OSMapInt -> Int -> Int -> Property 135 | prop_insertLookupWithKeyStrictValue2 (OSMapInt m) v i = 136 | not (null m) ==> 137 | isBottom $ snd $ insertLookupWithKey (\_ _ old -> if old == value then bottom else v) key v m 138 | where 139 | (key, value) = keyValueByIndex i m 140 | 141 | prop_updateLookupWithKeyStrictKey :: OSMapInt -> Maybe Int -> Bool 142 | prop_updateLookupWithKeyStrictKey (OSMapInt m) v = 143 | isBottom $ snd $ updateLookupWithKey (\_ _ -> v) bottom m 144 | 145 | prop_updateLookupWithKeyStrictValue1 :: OSMapInt -> Maybe Int -> Int -> Property 146 | prop_updateLookupWithKeyStrictValue1 (OSMapInt m) v i = 147 | not (null m) ==> 148 | isBottom $ snd $ updateLookupWithKey (\_ old -> if old == value then bottom else v) key m 149 | where 150 | (key, value) = keyValueByIndex i m 151 | 152 | prop_updateLookupWithKeyStrictValue2 :: OSMapInt -> Maybe Int -> Int -> Property 153 | prop_updateLookupWithKeyStrictValue2 (OSMapInt m) v i = 154 | not (null m) ==> 155 | isBottom $ snd $ updateLookupWithKey (\_ old -> if old == value then Just bottom else v) key m 156 | where 157 | (key, value) = keyValueByIndex i m 158 | 159 | prop_deleteLookupStrict :: OSMapInt -> Property 160 | prop_deleteLookupStrict (OSMapInt m) = 161 | not (null m) ==> 162 | isBottom $ snd $ deleteLookup bottom m 163 | 164 | prop_alterStrictKey :: OSMapInt -> Bool 165 | prop_alterStrictKey (OSMapInt m) = 166 | isBottom $ alter id bottom m 167 | 168 | prop_alterStrictFun1 :: OSMapInt -> Int -> Property 169 | prop_alterStrictFun1 (OSMapInt m) i = 170 | not (null m) ==> 171 | isBottom $ alter (\_ -> Just bottomInt) key m 172 | where 173 | key = keyByIndex i m 174 | 175 | prop_alterStrictFun2 :: OSMapInt -> Int -> Property 176 | prop_alterStrictFun2 (OSMapInt m) i = 177 | not (null m) ==> 178 | isBottom $ alter (\_ -> bottom) key m 179 | where 180 | key = keyByIndex i m 181 | 182 | prop_differenceWithStrictLeft :: OSMapInt -> Maybe Int -> Bool 183 | prop_differenceWithStrictLeft (OSMapInt m) v = 184 | isBottom $ differenceWith (\_ _ -> v) bottom m 185 | 186 | prop_differenceWithStrictRight :: OSMapInt -> Maybe Int -> Property 187 | prop_differenceWithStrictRight (OSMapInt m) v = 188 | not (null m) ==> 189 | isBottom $ differenceWith (\_ _ -> v) m bottom 190 | 191 | prop_differenceWithStrictFun1 :: OSMapInt -> Int -> Int -> Property 192 | prop_differenceWithStrictFun1 (OSMapInt m) v i = 193 | not (null m) ==> 194 | isBottom $ differenceWith (\_ _ -> Just bottom) m (insert key v m) 195 | where 196 | key = keyByIndex i m 197 | 198 | prop_differenceWithStrictFun2 :: OSMapInt -> Int -> Int -> Property 199 | prop_differenceWithStrictFun2 (OSMapInt m) v i = 200 | not (null m) ==> 201 | isBottom $ differenceWith (\_ _ -> bottom) m (insert key v m) 202 | where 203 | key = keyByIndex i m 204 | 205 | prop_intersectionWithStrictFun2 :: OSMapInt -> Int -> Int -> Property 206 | prop_intersectionWithStrictFun2 (OSMapInt m) v i = 207 | not (null m) ==> 208 | isBottom $ intersectionWith (\_ _ -> bottom) m (insert key v m) 209 | where 210 | key = keyByIndex i m 211 | 212 | prop_updateWithKeyStrictKey :: OSMapInt -> Maybe Int -> Bool 213 | prop_updateWithKeyStrictKey (OSMapInt m) v = 214 | isBottom $ updateWithKey (\_ _ -> v) bottom m 215 | 216 | prop_updateWithKeyStrictValue1 :: OSMapInt -> Maybe Int -> Int -> Property 217 | prop_updateWithKeyStrictValue1 (OSMapInt m) v i = 218 | not (null m) ==> 219 | isBottom $ updateWithKey (\_ old -> if old == value then bottom else v) key m 220 | where 221 | (key, value) = keyValueByIndex i m 222 | 223 | prop_updateWithKeyStrictValue2 :: OSMapInt -> Maybe Int -> Int -> Property 224 | prop_updateWithKeyStrictValue2 (OSMapInt m) v i = 225 | not (null m) ==> 226 | isBottom $ updateWithKey (\_ old -> if old == value then Just bottom else v) key m 227 | where 228 | (key, value) = keyValueByIndex i m 229 | 230 | prop_insertWithKeyStrictKey :: OSMapInt -> Int -> Bool 231 | prop_insertWithKeyStrictKey (OSMapInt m) v = 232 | isBottom $ insertWithKey (\_ _ _ -> 0) bottom v m 233 | 234 | prop_insertWithKeyStrictValue1 :: OSMapInt -> Int -> Bool 235 | prop_insertWithKeyStrictValue1 (OSMapInt m) k = 236 | isBottom $ insertWithKey (\_ _ _ -> 0) k bottom m 237 | 238 | prop_insertWithKeyStrictValue2 :: OSMapInt -> Int -> Int -> Property 239 | prop_insertWithKeyStrictValue2 (OSMapInt m) v i = 240 | not (null m) ==> 241 | isBottom $ insertWithKey (\_ _ old -> if old == value then bottom else v) key v m 242 | where 243 | (key, value) = keyValueByIndex i m 244 | 245 | prop_mapKeysStrict :: OSMapInt -> Int -> Property 246 | prop_mapKeysStrict (OSMapInt m) i = 247 | not (null m) ==> 248 | isBottom $ mapKeys (\k -> if k == key then bottom else k) m 249 | where 250 | key = keyByIndex i m 251 | 252 | prop_fmapStrict :: OSMapInt -> Int -> Property 253 | prop_fmapStrict (OSMapInt m) i = 254 | not (null m) ==> 255 | isBottom $ fmap (\x -> if x == value then bottom else x) m 256 | where 257 | value = valueByIndex i m 258 | 259 | prop_traverseStrict :: OSMapInt -> Int -> Property 260 | prop_traverseStrict (OSMapInt m) i = 261 | not (null m) ==> 262 | isBottom $ fmapDefault (\x -> if x == value then bottom else x) m 263 | where 264 | value = valueByIndex i m 265 | -------------------------------------------------------------------------------- /strict-data/test/Doc.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = doctest ["src"] 7 | 8 | -------------------------------------------------------------------------------- /strict-data/test/Fail.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Fail where 3 | 4 | import Data.Fail 5 | 6 | import Test.Framework 7 | 8 | test_partitionFails :: IO () 9 | test_partitionFails = 10 | do assertEqual ([]::[Int], []) (partitionFails []) 11 | assertEqual ([1::Int], []) (partitionFails [Ok 1]) 12 | assertEqual ([]::[Int], ["bad"]) (partitionFails [Fail "bad"]) 13 | assertEqual ([1,2,3::Int], ["bad1", "bad2"]) 14 | (partitionFails [Ok 1, Fail "bad1", Ok 2, Ok 3, Fail "bad2"]) 15 | -------------------------------------------------------------------------------- /strict-data/test/Option.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Option where 3 | 4 | import Data.Option 5 | 6 | import Control.Monad (forM_) 7 | import Data.List 8 | import Test.Framework 9 | 10 | test_ord :: IO () 11 | test_ord = 12 | let list = [None, None, Some "x", Some "x", Some "y"] 13 | in forM_ (permutations list) $ \perm -> 14 | assertEqual list (sort perm) 15 | 16 | -------------------------------------------------------------------------------- /strict-data/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Main where 3 | 4 | import {-@ HTF_TESTS @-} Data.Map.OrderedSpec 5 | import {-@ HTF_TESTS @-} Fail 6 | import {-@ HTF_TESTS @-} Option 7 | import {-@ HTF_TESTS @-} StrictList 8 | import {-@ HTF_TESTS @-} StrictVector 9 | import {-@ HTF_TESTS @-} StrictVector.Mutable 10 | 11 | import Test.Framework 12 | 13 | main :: IO () 14 | main = htfMain htf_importedTests 15 | -------------------------------------------------------------------------------- /strict-data/test/StrictList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# OPTIONS_GHC -F -pgmF htfpp -fno-warn-type-defaults #-} 3 | module StrictList (htf_thisModulesTests) where 4 | 5 | import Data.Option 6 | import Data.StrictList 7 | import Data.StrictTuple 8 | 9 | import Prelude hiding 10 | ( (!!) 11 | , all 12 | , any 13 | , break 14 | , concat 15 | , concatMap 16 | , drop 17 | , dropWhile 18 | , elem 19 | , filter 20 | , length 21 | , lookup 22 | , map 23 | , mapM 24 | , mapM_ 25 | , notElem 26 | , null 27 | , replicate 28 | , reverse 29 | , span 30 | , take 31 | , takeWhile 32 | , unzip 33 | , zip 34 | , zipWith 35 | ) 36 | import Test.Framework 37 | import qualified Prelude as P 38 | 39 | test_nub :: IO () 40 | test_nub = 41 | do assertEqual (sl [1, 5, 2] :: SL Int) $ nub (sl [1, 5, 1, 2, 5, 2]) 42 | 43 | test_unzip :: IO () 44 | test_unzip = 45 | do assertEqual ((1:!2:!Nil) :!: ('a':!'b':!Nil)) (unzip ((1 :!: 'a') :! (2 :!: 'b') :! Nil)) 46 | assertEqual ((1:!2:!Nil) :!: ('a':!'b':!Nil)) (unzipL [(1:!:'a'),(2:!:'b')]) 47 | assertEqual ((1:!2:!Nil) :!: ('a':!'b':!Nil)) (unzipLL [(1,'a'),(2,'b')]) 48 | 49 | test_dropWhileEnd :: IO () 50 | test_dropWhileEnd = 51 | do assertEqual Nil $ dropWhileEnd (<= 1) $ Nil 52 | assertEqual Nil $ dropWhileEnd (<= 1) $ 1 :! Nil 53 | assertEqual (1 :! 2 :! Nil) $ dropWhileEnd (<= 1) $ 1 :! 2 :! 1 :! Nil 54 | 55 | 56 | prop_partition :: [Int] -> Bool 57 | prop_partition l = 58 | let me :: ([Int], [Int]) 59 | me = (\(xs, ys) -> (toLazyList xs, toLazyList ys)) $ partition even $ fromLazyList l 60 | in (P.filter even l, P.filter odd l) == me 61 | 62 | test_insert :: IO () 63 | test_insert = 64 | do assertEqual (1 :! Nil) (insert 1 Nil) 65 | assertEqual (1 :! 2 :! Nil) (insert 1 (2 :! Nil)) 66 | assertEqual (1 :! 2 :! Nil) (insert 2 (1 :! Nil)) 67 | assertEqual (1 :! 2 :! 3 :! Nil) (insert 2 (1 :! 3 :! Nil)) 68 | assertEqual (1 :! 2 :! 3 :! Nil) (insert 3 (1 :! 2 :! Nil)) 69 | assertEqual (1 :! 2 :! 2 :! Nil) (insert 2 (1 :! 2 :! Nil)) 70 | assertEqual (2 :! 3 :! 1 :! Nil) (insert 2 (3 :! 1 :! Nil)) 71 | 72 | test_lookup :: IO () 73 | test_lookup = 74 | do assertEqual None (lookup True (mk [])) 75 | assertEqual (Some 'a') (lookup True (mk [(True, 'a')])) 76 | assertEqual (Some 'a') (lookup True (mk [(False, 'b'),(True, 'a')])) 77 | assertEqual (Some 'a') (lookup True (mk [(False, 'b'),(True, 'a'),(False, 'c')])) 78 | assertEqual (Some 'a') (lookup True (mk [(False, 'b'),(False, 'c'),(True, 'a')])) 79 | assertEqual None (lookup True (mk [(False, 'b')])) 80 | assertEqual None (lookup True (mk [(False, 'a'), (False, 'b')])) 81 | where 82 | mk :: [(Bool,Char)] -> StrictList (Bool :!: Char) 83 | mk = fromLazyList . fmap fromLazyTuple 84 | 85 | prop_take :: Int -> [Int] -> Bool 86 | prop_take l lst = 87 | let me :: [Int] 88 | me = toLazyList $ take l (fromLazyList lst) 89 | in P.take l lst == me 90 | 91 | -- test_sort :: IO () 92 | -- test_sort = 93 | -- do let list = fromLazyList [1..133] 94 | -- list' <- Cpm.Util.Random.shuffle (toLazyList list) 95 | -- assertEqual list (sort (fromLazyList list')) 96 | 97 | test_headOpt :: IO () 98 | test_headOpt = 99 | do assertEqual (Some "B") $ headOpt $ fromLazyList ["B","C"] 100 | assertEqual None $ headOpt (Nil :: StrictList ()) 101 | 102 | test_lastOpt :: IO () 103 | test_lastOpt = 104 | do assertEqual (Some 5) $ lastOpt $ fromLazyList [2,4,5] 105 | assertEqual (Some 5) $ lastOpt $ fromLazyList [5] 106 | assertEqual None $ lastOpt $ (Nil :: StrictList ()) 107 | 108 | test_findIndex :: IO () 109 | test_findIndex = 110 | do assertEqual None $ findIndex (== "A") $ fromLazyList ["B","C"] 111 | assertEqual None $ findIndex (== "A") Nil 112 | assertEqual (Some 1) $ findIndex (== "C") $ fromLazyList ["B","C","D"] 113 | assertEqual (Some 0) $ findIndex (/= "C") $ fromLazyList ["B","C","D"] 114 | 115 | test_reverse :: IO () 116 | test_reverse = 117 | do assertEqual (fromLazyList ["D","C","B"]) (reverse $ fromLazyList ["B","C","D"]) 118 | assertEqual (Nil :: StrictList ()) $ reverse Nil 119 | 120 | test_replicate :: IO () 121 | test_replicate = 122 | do assertEqual (replicate 3 'a') (fromLazyList (P.replicate 3 'a')) 123 | assertEqual (replicate 3 'b') ('b' :! 'b' :! 'b' :! Nil) 124 | assertEqual (replicate 0 'c') Nil 125 | assertEqual (replicate 0 'd') (fromLazyList (P.replicate 0 'e')) 126 | 127 | test_dropWhile :: IO () 128 | test_dropWhile = 129 | do assertEqual (fromLazyList [5]) $ dropWhile even $ fromLazyList [2,4,5] 130 | assertEqual (fromLazyList [2,4,5]) $ dropWhile odd $ fromLazyList [2,4,5] 131 | assertEqual Nil $ dropWhile (>=1) $ fromLazyList [2,4,5] 132 | 133 | test_stripPrefix :: IO () 134 | test_stripPrefix = 135 | do assertEqual (Just Nil) $ stripPrefix Nil (Nil :: SL Int) 136 | assertEqual (Just $ 1 :! Nil) $ stripPrefix Nil (1 :! Nil) 137 | assertEqual (Just Nil) $ stripPrefix (1 :! Nil) (1 :! Nil) 138 | assertEqual (Just $ 3 :! Nil) $ stripPrefix (1 :! 2 :! Nil) (1 :! 2 :! 3 :! Nil) 139 | assertEqual Nothing $ stripPrefix (1 :! Nil) Nil 140 | 141 | test_stripSuffix :: IO () 142 | test_stripSuffix = 143 | do assertEqual (Just Nil) $ stripSuffix Nil (Nil :: SL Int) 144 | assertEqual (Just $ 1 :! Nil) $ stripSuffix Nil (1 :! Nil) 145 | assertEqual (Just Nil) $ stripSuffix (1 :! Nil) (1 :! Nil) 146 | assertEqual (Just $ 1 :! Nil) $ stripSuffix (2 :! 3 :! Nil) (1 :! 2 :! 3 :! Nil) 147 | assertEqual Nothing $ stripSuffix (1 :! Nil) Nil 148 | 149 | test_deleteIdx :: IO () 150 | test_deleteIdx = 151 | do assertEqual (1 :! Nil) $ deleteIdx (-5) (1 :! Nil) 152 | assertEqual (1 :! 3 :! Nil) $ deleteIdx 1 (1 :! 2 :! 3 :! Nil) 153 | assertEqual Nil $ deleteIdx 0 ("B" :! Nil) 154 | assertEqual (fromLazyList ["a","B","C","D","E"]) $ 155 | deleteIdx 5 (fromLazyList ["a","B","C","D","E","Q"]) 156 | assertEqual (fromLazyList [1,3,2,4]) $ 157 | deleteIdx 4 (fromLazyList [1,3,2,4]) 158 | 159 | test_atIdx :: IO () 160 | test_atIdx = 161 | do assertEqual (Some 1) $ atIdx 0 (1 :! Nil) 162 | assertEqual None $ atIdx 6 (1 :! 2 :! 3 :! Nil) 163 | assertEqual None $ atIdx (-3) ("B" :! Nil) 164 | assertEqual (Some "a") $ atIdx 5 (fromLazyList ["g","q","s","u","xc","a"]) 165 | 166 | test_snoc :: IO () 167 | test_snoc = 168 | do assertEqual (True :! Nil) (snoc Nil True) 169 | assertEqual (False :! True :! Nil) (snoc (False :! Nil) True) 170 | 171 | test_transpose :: IO () 172 | test_transpose = 173 | do assertEqual (f [[1,4],[2,5],[3,6]]) (transpose (f [[1,2,3],[4,5,6]])) 174 | assertEqual (f [[1,2,3],[4,5],[6]]) (transpose (f [[1,4],[2],[],[3,5,6]])) 175 | where 176 | f = fmap sl . sl 177 | 178 | prop_difference :: SL Int -> SL Int -> Bool 179 | prop_difference xs ys = (xs +!+ ys) \!\ xs == ys 180 | 181 | test_delete :: IO () 182 | test_delete = 183 | do assertEqual (sl "bnana") (delete 'a' (sl "banana")) 184 | assertEqual Nil (delete 'a' Nil) 185 | 186 | test_merge :: IO () 187 | test_merge = 188 | assertEqual (sl "abcdef" :: SL Char) (merge (sl "acde") (sl "abdf")) 189 | -------------------------------------------------------------------------------- /strict-data/test/StrictVector.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-name-shadowing -F -pgmF htfpp #-} 2 | module StrictVector where 3 | 4 | import Data.Option 5 | import Data.StrictVector 6 | 7 | import Control.Exception 8 | import Test.Framework 9 | import qualified Data.List as L 10 | import qualified Data.Vector.Generic as VG 11 | 12 | prop_groupBy :: [(Int,Int)] -> Bool 13 | prop_groupBy l = 14 | let eq (_,x) (_,y) = x == y 15 | res1 = groupBy eq (fromList l) 16 | res2 = fmap fromList (fromList (L.groupBy eq l)) 17 | in res2 == res1 18 | 19 | -- prop_groupOn :: [(Int,Int)] -> Bool 20 | -- prop_groupOn l = 21 | -- let proj = snd 22 | -- res1 = groupOn proj (fromList l) 23 | -- res2 = fmap (second fromList) (fromList (L.groupOn proj l)) 24 | -- in res2 == res1 25 | 26 | test_lookingAround :: IO () 27 | test_lookingAround = 28 | do assertEqual expected1 (f input1) 29 | assertEqual [] (f []) 30 | assertEqual [(Nothing,1,Nothing)] (f [1]) 31 | assertEqual [(Nothing,1,Just 2),(Just 1,2,Nothing)] (f [1,2]) 32 | where 33 | f :: [Int] -> [(Maybe Int, Int, Maybe Int)] 34 | f list = toList (lookAround (fromList list)) 35 | input1 = [1,2,3] 36 | expected1 = [ (Nothing, 1, Just 2) 37 | , (Just 1, 2, Just 3) 38 | , (Just 2, 3, Nothing) 39 | ] 40 | 41 | test_uncons :: IO () 42 | test_uncons = 43 | let atoe :: Int 44 | atoe = 42 45 | in do assertEqual None (uncons $ fromList $ L.drop 1 [atoe]) 46 | assertEqual (Some (atoe, fromList [5,2,3])) 47 | (uncons $ fromList [atoe,5,2,3]) 48 | 49 | test_binarySearchL :: IO () 50 | test_binarySearchL = 51 | do assertEqual 0 (binarySearchL (flip compare 0) (fromList [0,1,2])) 52 | assertEqual 1 (binarySearchL (flip compare 1) (fromList [0,1,2])) 53 | assertEqual 1 (binarySearchL (flip compare 1) (fromList [0,1,1,2])) 54 | assertEqual 2 (binarySearchL (flip compare 2) (fromList [0,1,2])) 55 | assertEqual 3 (binarySearchL (flip compare 3) (fromList [0,1,2])) 56 | 57 | test_binarySearchR :: IO () 58 | test_binarySearchR = 59 | do assertEqual 0 (binarySearchR (flip compare 0) (fromList [1,2,3])) 60 | assertEqual 1 (binarySearchR (flip compare 0) (fromList [0,1,2])) 61 | assertEqual 2 (binarySearchR (flip compare 1) (fromList [0,1,2])) 62 | assertEqual 3 (binarySearchR (flip compare 1) (fromList [0,1,1,2])) 63 | assertEqual 3 (binarySearchR (flip compare 2) (fromList [0,1,2])) 64 | assertEqual 3 (binarySearchR (flip compare 3) (fromList [0,1,2])) 65 | 66 | test_fromListStrict :: IO () 67 | test_fromListStrict = 68 | do let err = ErrorCall "..." 69 | res <- try $ (VG.fromList [1,2,throw err] :: Vector Int) `seq` return () 70 | assertEqual (Left err) res 71 | -------------------------------------------------------------------------------- /strict-data/test/StrictVector/Mutable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module StrictVector.Mutable where 3 | 4 | import Data.StrictVector.Mutable 5 | 6 | import Control.Exception 7 | import Test.Framework 8 | import qualified Data.Vector.Generic.Mutable as VGM 9 | 10 | test_replicateStrict :: IO () 11 | test_replicateStrict = 12 | do let err = ErrorCall "..." 13 | res <- try $ (VGM.replicate 10 (throw err :: ()) :: IO (IOVector ())) 14 | assertEqual (Left err) (res >> Right ()) 15 | 16 | test_writeStrict :: IO () 17 | test_writeStrict = 18 | do let err = ErrorCall "..." 19 | vec <- VGM.replicate 1 () 20 | res <- try $ VGM.write (vec :: IOVector ()) 0 (throw err) 21 | assertEqual (Left err) res 22 | 23 | test_setStrict :: IO () 24 | test_setStrict = 25 | do let err = ErrorCall "..." 26 | vec <- VGM.replicate 1 () 27 | res <- try $ VGM.set (vec :: IOVector ()) (throw err) 28 | assertEqual (Left err) res 29 | -------------------------------------------------------------------------------- /text-plus/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright factis research GmbH (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Kierán Meinhardt nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /text-plus/README.md: -------------------------------------------------------------------------------- 1 | # text-plus 2 | -------------------------------------------------------------------------------- /text-plus/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /text-plus/src/Data/Text/Plus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} 5 | module Data.Text.Plus 6 | ( module Data.Text 7 | , module Data.Text.Encoding 8 | , decodeUtf8M 9 | , showText 10 | , readText 11 | , groupOn 12 | , withoutTags 13 | , showTable 14 | , showTableRaw 15 | , filename 16 | , splitOnNoEmpty 17 | , nothingIfEmpty 18 | , noneIfEmpty 19 | , emptyIfNone 20 | , limitTo 21 | , sep, unsep, unsep' 22 | , shorten 23 | , shortenL 24 | , firstToUpper 25 | , shortenLinesL 26 | , lenientDecodeUtf8, lenientDecodeUtf8L 27 | , toLazy 28 | , fromLazy 29 | , indicesOfOccurences 30 | , tokenize 31 | , commonPrefixTotal 32 | , firstLine 33 | , firstParagraph 34 | , escapeXml 35 | , fixed 36 | , fixed' 37 | ) 38 | where 39 | 40 | import Data.Fail 41 | import Data.Option 42 | import Safe.Plus 43 | 44 | import Data.Char (isSpace) 45 | import Data.Function 46 | import Data.Maybe 47 | import Data.Monoid 48 | import Data.Text 49 | import Data.Text.Encoding hiding (Decoding(Some)) 50 | import Test.QuickCheck 51 | import qualified Data.ByteString as BS 52 | import qualified Data.ByteString.Lazy as BSL 53 | import qualified Data.Char as C 54 | import qualified Data.Foldable as F 55 | import qualified Data.Text as T 56 | import qualified Data.Text.Encoding.Error as TE 57 | import qualified Data.Text.Lazy as TL 58 | import qualified Data.Text.Lazy.Encoding as TLE 59 | 60 | fixed :: Int -> T.Text -> T.Text 61 | fixed = fixed' '0' 62 | 63 | fixed' :: Char -> Int -> T.Text -> T.Text 64 | fixed' ch i s = 65 | let n = i - T.length s 66 | in T.replicate n (T.singleton ch) `T.append` s 67 | 68 | instance Arbitrary T.Text where 69 | arbitrary = T.pack <$> arbitrary 70 | shrink t = T.pack <$> shrink (T.unpack t) 71 | 72 | fromLazy :: TL.Text -> T.Text 73 | fromLazy = TL.toStrict 74 | 75 | toLazy :: T.Text -> TL.Text 76 | toLazy = TL.fromStrict 77 | 78 | showText :: Show a => a -> T.Text 79 | showText = T.pack . show 80 | 81 | showTextL :: Show a => a -> TL.Text 82 | showTextL = TL.pack . show 83 | 84 | readText :: Read a => T.Text -> a 85 | readText = read . T.unpack 86 | 87 | limitTo :: Int -> T.Text -> T.Text 88 | limitTo lim t 89 | | lim <= 5 = t 90 | | T.length t <= lim = t 91 | | otherwise = 92 | T.take (lim - 4) t 93 | <> "..." 94 | <> T.drop (T.length t - 1) t 95 | 96 | groupOn :: Eq a => (Char -> a) -> Text -> [(a, T.Text)] 97 | groupOn _ "" = [] 98 | groupOn proj t = (x', x `T.cons` ys) : groupOn proj zs 99 | where 100 | x = T.head t 101 | xs = T.tail t 102 | x' = proj x 103 | (ys,zs) = T.span ((==x') . proj) xs 104 | 105 | firstToUpper :: T.Text -> T.Text 106 | firstToUpper t = 107 | case T.uncons t of 108 | Nothing -> "" 109 | Just (fstChr, rstText) -> 110 | C.toUpper fstChr `cons` rstText 111 | 112 | -- |Removes HTML Tags 113 | withoutTags :: T.Text -> T.Text 114 | withoutTags = 115 | let betweenTags ('<':xs) = inTag xs 116 | betweenTags (x:xs) = x:betweenTags xs 117 | betweenTags [] = [] 118 | inTag ('>':xs) = betweenTags xs 119 | inTag ('\'':xs) = inSingQuot xs 120 | inTag ('"':xs) = inDoubleQuot xs 121 | inTag (_:xs) = inTag xs 122 | inTag [] = [] -- incorrect HTML 123 | inSingQuot ('\'':xs) = inTag xs 124 | inSingQuot (_:xs) = inSingQuot xs 125 | inSingQuot [] = [] -- incorrect HTML 126 | inDoubleQuot ('\"':xs) = inTag xs 127 | inDoubleQuot (_:xs) = inDoubleQuot xs 128 | inDoubleQuot [] = [] -- incorrect HTML 129 | in T.pack . betweenTags . T.unpack 130 | 131 | -- indicesOfOccurences needle haystack returns all indices i s.t. 132 | -- 133 | -- prop> needle `T.isPrefixOf` (T.drop i haystack) 134 | -- 135 | -- Note that: T.breakOnAll - does not return overlapping matches, e.g. 136 | -- 137 | -- prop> indicesOfOccurences "edited" "editedited" == [0,4] 138 | -- 139 | -- but 140 | -- 141 | -- prop> map (T.length . fst) (T.breakOnAll "edited" "editedited") == [0] 142 | -- 143 | indicesOfOccurences :: T.Text -> T.Text -> [Int] 144 | indicesOfOccurences needle = go 0 145 | where 146 | go off haystack 147 | | Just (_, matchTail) <- T.uncons match = newOff:go (newOff+1) matchTail 148 | | otherwise = [] 149 | where 150 | newOff = off + T.length prefix 151 | (prefix, match) = T.breakOn needle haystack 152 | 153 | -- | Simple tokenizer - that doesn't destroy delimiters, e.g. 154 | -- 155 | -- >>> tokenize (T.pack "This is blind-text, with punctuation.") 156 | -- ["This"," ","is"," ","blind","-","text",", ","with"," ","punctuation","."] 157 | -- 158 | -- prop> T.concat (tokenize x) == x 159 | -- 160 | -- Note: URLs, numbers won't be handled very well. 161 | tokenize :: T.Text -> [T.Text] 162 | tokenize = T.groupBy ((==) `on` C.isAlphaNum) 163 | 164 | -- | @commonPrefixTotal s t@ returns a trippel @(r,st,tt)@ s.t. 165 | -- @ 166 | -- s = r `T.append` st, t = r `T.append` tt 167 | -- @ 168 | -- such that @r@ is longest possible. 169 | -- 170 | -- Note: Contrary to Data.commonPrefix there is no special case when @T.null r@. 171 | commonPrefixTotal :: T.Text -> T.Text -> (T.Text, T.Text, T.Text) 172 | commonPrefixTotal s t = fromMaybe ("", s, t) $ T.commonPrefixes s t 173 | 174 | showTable :: (Traversable t) => [(T.Text, a -> T.Text)] -> t a -> T.Text 175 | showTable headersAccessors rows = 176 | showTableRaw (fmap fst headersAccessors) (fmap (\x -> fmap (($ x) . snd) headersAccessors) rows) 177 | 178 | showTableRaw :: (Traversable t1, Traversable t2) => [T.Text] -> t1 (t2 T.Text) -> T.Text 179 | showTableRaw headers rows = table 180 | where 181 | rows' = fmap (fmap (wrap ' ')) rows 182 | columnHeaders = 183 | fmap (wrap ' ') headers 184 | header = renderRow columnHeaders 185 | headerBodySeperator = 186 | wrap '|' (T.intercalate "+" (fmap (`T.replicate` "-") fieldWidths)) 187 | renderRow rowElems = 188 | wrap '|' (T.intercalate "|" (adjust (F.toList rowElems))) 189 | wrap char = T.cons char . (`T.snoc` char) 190 | table = 191 | flip T.snoc '\n' . T.intercalate "\n" $ 192 | header : headerBodySeperator : F.toList (fmap renderRow rows') 193 | adjust = Prelude.zipWith (`T.justifyLeft` ' ') fieldWidths 194 | fieldWidths = 195 | Prelude.foldr (Prelude.zipWith (\a b -> max (T.length a) b)) 196 | (F.toList (fmap T.length columnHeaders)) (fmap F.toList rows') 197 | 198 | nothingIfEmpty :: T.Text -> Maybe T.Text 199 | nothingIfEmpty t = 200 | if T.null $ T.strip t then Nothing else Just t 201 | 202 | noneIfEmpty :: T.Text -> Option T.Text 203 | noneIfEmpty = maybeToOption . nothingIfEmpty 204 | 205 | emptyIfNone :: Option T.Text -> T.Text 206 | emptyIfNone None = T.empty 207 | emptyIfNone (Some t) = t 208 | 209 | sep :: T.Text -> Char -> T.Text -> T.Text 210 | sep prefix ch suffix 211 | | T.any (==ch) prefix = 212 | safeError ("Oh dear! Won't separate `" ++ T.unpack prefix ++ "' with `" ++ show ch 213 | ++ "' because it contains that character!") 214 | | otherwise = T.concat [prefix, T.singleton ch, suffix] 215 | 216 | unsep' :: Monad m => Char -> T.Text -> m (T.Text, T.Text) 217 | unsep' ch full = 218 | case T.span (/=ch) full of 219 | (prefix, T.uncons -> Just (ch', suffix)) | ch == ch' -> return (prefix, suffix) 220 | _ -> safeFail ("Can't unsep `" ++ T.unpack full ++ "' using `" ++ show ch ++ "'.") 221 | 222 | unsep :: Char -> T.Text -> (T.Text, T.Text) 223 | unsep ch x = safeFromOk (unsep' ch x) 224 | 225 | shorten :: Int -> T.Text -> T.Text 226 | shorten len = TL.toStrict . shortenL len . TL.fromStrict 227 | 228 | shortenL :: Int -> TL.Text -> TL.Text 229 | shortenL (fromIntegral -> maxLen) s = 230 | let actualLen = TL.length s 231 | skipMsg = TL.concat ["... (", showTextL (actualLen - maxLen), " more chars)"] 232 | skipMsgLen = TL.length skipMsg 233 | in if actualLen <= maxLen + skipMsgLen 234 | then s 235 | else TL.concat [TL.take maxLen s, skipMsg] 236 | 237 | shortenLinesL :: Int -> Int -> TL.Text -> TL.Text 238 | shortenLinesL maxLines maxLineLength (Prelude.map (shortenL maxLineLength) . TL.lines -> xs) = 239 | let actualLines = Prelude.length xs 240 | skipMsg = TL.concat ["(", showTextL (actualLines - maxLines), " more lines)"] 241 | lines 242 | | actualLines <= maxLines + 1 = xs 243 | | otherwise = Prelude.take maxLines xs ++ [skipMsg] 244 | in TL.unlines lines 245 | 246 | filename :: T.Text -> T.Text 247 | filename = T.replace "?" "_" . T.replace "/" "_" . T.replace "." "_" . T.replace " " "_" 248 | 249 | splitOnNoEmpty :: T.Text -> T.Text -> [T.Text] 250 | splitOnNoEmpty break t = 251 | Prelude.filter (/= "") $ T.splitOn break t 252 | 253 | lenientDecodeUtf8 :: BS.ByteString -> T.Text 254 | lenientDecodeUtf8 = decodeUtf8With TE.lenientDecode 255 | 256 | lenientDecodeUtf8L :: BSL.ByteString -> TL.Text 257 | lenientDecodeUtf8L = TLE.decodeUtf8With TE.lenientDecode 258 | 259 | decodeUtf8M :: BS.ByteString -> Fail T.Text 260 | decodeUtf8M bs = 261 | case decodeUtf8' bs of 262 | Left (TE.DecodeError err (Just w8)) -> 263 | Fail $ 264 | "Failed decoding " ++ show bs ++ " as UTF-8 on character " ++ show w8 ++ ": " ++ err 265 | Left (TE.DecodeError err Nothing) -> 266 | Fail $ "Failed decoding " ++ show bs ++ " as UTF-8: " ++ err 267 | Left _ -> safeError "Never used according to documentation." 268 | Right txt -> Ok txt 269 | 270 | firstParagraph :: T.Text -> T.Text 271 | firstParagraph = 272 | T.unlines . Prelude.takeWhile (not . endOfParagraph) . T.lines 273 | where 274 | endOfParagraph = T.all isSpace 275 | 276 | firstLine :: T.Text -> T.Text 277 | firstLine = T.takeWhile (/='\n') 278 | 279 | escapeXml :: T.Text -> T.Text 280 | escapeXml = T.concatMap escape 281 | where 282 | escape c = 283 | case c of 284 | '<' -> "<" 285 | '>' -> ">" 286 | '&' -> "&" 287 | '"' -> """ 288 | '\'' -> "'" 289 | c -> T.singleton c 290 | -------------------------------------------------------------------------------- /text-plus/test/Data/Text/PlusSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Data.Text.PlusSpec (htf_thisModulesTests) where 4 | 5 | import Data.Text.Plus 6 | 7 | import Test.Framework 8 | import qualified Data.Char as C 9 | import qualified Data.Text as T 10 | 11 | test_groupOn :: IO () 12 | test_groupOn = 13 | do assertEqual [] $ groupOn id "" 14 | assertEqual [(False, "abc"), (True, "123"), (False, "def")] $ groupOn C.isDigit "abc123def" 15 | 16 | test_firstToUpper :: IO () 17 | test_firstToUpper = 18 | do assertEqual "Hallo" $ firstToUpper "hallo" 19 | assertEqual "HAllo" $ firstToUpper "HAllo" 20 | assertEqual "" $ firstToUpper "" 21 | 22 | test_withoutTags :: IO () 23 | test_withoutTags = 24 | do assertEqual "Hello laboratory report!" 25 | (withoutTags $ "

Hello 

laboratory
report!

") 26 | assertEqual "Hello laboratory report!" 27 | (withoutTags $ "

x<\">Hello 

laboratory
report!

") 28 | assertEqual "Hello report!" 29 | (withoutTags $ "

Hello report!

") 30 | 31 | prop_indicesOverlapping :: Property 32 | prop_indicesOverlapping = once $ prop_indices "aba" "ababa" 33 | 34 | prop_indicesThree :: Property 35 | prop_indicesThree = once $ prop_indices "a" "ababa" 36 | 37 | prop_indicesNone :: Property 38 | prop_indicesNone = once $ prop_indices "foo" "ababa" 39 | 40 | prop_indicesSingle :: Property 41 | prop_indicesSingle = once $ prop_indices "bab" "ababa" 42 | 43 | prop_indices :: T.Text -> T.Text -> Property 44 | prop_indices n h = not (T.null n) ==> 45 | (indicesOfOccurences n h === [ i | i <- [0..(T.length h - 1)], n `T.isPrefixOf` (T.drop i h)]) 46 | 47 | test_tokenize :: IO () 48 | test_tokenize = 49 | assertEqual ["This"," ","is"," ","blind","-","text",", ","with", " ", "punctuation", "."] $ 50 | tokenize "This is blind-text, with punctuation." 51 | 52 | test_tokenizeWithNum :: IO () 53 | test_tokenizeWithNum = 54 | assertEqual ["100"," ","sheep"] $ tokenize "100 sheep" 55 | 56 | test_tokenizeEmpty :: IO () 57 | test_tokenizeEmpty = 58 | assertEqual [] $ tokenize "" 59 | 60 | test_showTableRaw :: IO () 61 | test_showTableRaw = 62 | let header = ["Col1", "Col2", "Col3"] 63 | table = [["longfield", "-", ""], ["short", "longfield", ""]] 64 | in assertEqual (showTableRaw header table) $ 65 | T.concat 66 | [ "| Col1 | Col2 | Col3 |\n" 67 | , "|-----------+-----------+------|\n" 68 | , "| longfield | - | |\n" 69 | , "| short | longfield | |\n" 70 | ] 71 | 72 | test_shortenL :: IO () 73 | test_shortenL = 74 | do assertEqual "123456789012345678901" (shortenL 20 "123456789012345678901") 75 | assertEqual "123456789012345678901" (shortenL 21 "123456789012345678901") 76 | assertEqual "123456789012345678901" (shortenL 22 "123456789012345678901") 77 | assertEqual "123456789012345678901" (shortenL 2 "123456789012345678901") 78 | assertEqual "1... (20 more chars)" (shortenL 1 "123456789012345678901") 79 | assertEqual "... (21 more chars)" (shortenL 0 "123456789012345678901") 80 | 81 | test_shortenLinesL1 :: IO () 82 | test_shortenLinesL1 = 83 | assertEqual outp (shortenLinesL 2 1 inp) 84 | where 85 | outp = 86 | "1... (20 more chars)\n\ 87 | \1... (20 more chars)\n\ 88 | \(4 more lines)\n" 89 | inp = 90 | "123456789012345678901\n123456789012345678901\n123456789012345678901\n\ 91 | \123456789012345678901\n123456789012345678901\n123456789012345678901" 92 | 93 | test_shortenLinesL2 :: IO () 94 | test_shortenLinesL2 = 95 | assertEqual outp (shortenLinesL 0 0 inp) 96 | where 97 | outp = "(6 more lines)\n" 98 | inp = 99 | "123456789012345678901\n123456789012345678901\n123456789012345678901\n\ 100 | \123456789012345678901\n123456789012345678901\n123456789012345678901" 101 | 102 | test_filename :: IO () 103 | test_filename = 104 | do assertEqual "Foo" (filename "Foo") 105 | assertEqual "Foo_Bar" (filename "Foo Bar") 106 | assertEqual "Foo_Bar" (filename "Foo/Bar") 107 | assertEqual "Foo_Bar" (filename "Foo.Bar") 108 | assertEqual "Foo_Bar" (filename "Foo?Bar") 109 | 110 | test_sepUnsep :: IO () 111 | test_sepUnsep = 112 | do assertEqual ("foo|bar") (sep "foo" '|' "bar") 113 | assertEqual ("foo", "bar") (unsep '|' "foo|bar") 114 | assertEqual ("foo", "bar|baz") (unsep '|' "foo|bar|baz") 115 | 116 | test_firstLine :: IO () 117 | test_firstLine = 118 | do assertEqual "Hello World" (firstLine "Hello World") 119 | assertEqual "Hello World" (firstLine "Hello World\nsecond line") 120 | assertEqual "Hello World " (firstLine "Hello World \nsecond line") 121 | 122 | test_firstParagraph :: IO () 123 | test_firstParagraph = 124 | do assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld" 125 | assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n" 126 | assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n\nSecond paragraph.\n" 127 | assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n\nSecond paragraph." 128 | assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n\nSecond paragraph.\n\nThird." 129 | assertEqual "Hello\nWorld\n" $ firstParagraph "Hello\nWorld\n \nSecond paragraph." 130 | 131 | test_escapeXml :: IO () 132 | test_escapeXml = 133 | do assertEqual "foobar" (escapeXml "foobar") 134 | assertEqual "Hallo <Welt>" (escapeXml "Hallo ") 135 | assertEqual "Hallo 'Welt>" (escapeXml "Hallo 'Welt>") 136 | -------------------------------------------------------------------------------- /text-plus/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Main where 3 | 4 | import {-@ HTF_TESTS @-} Data.Text.PlusSpec 5 | 6 | import Test.DocTest 7 | import Test.Framework 8 | 9 | main :: IO () 10 | main = 11 | do doctest ["src"] 12 | htfMain htf_importedTests 13 | -------------------------------------------------------------------------------- /text-plus/text-plus.cabal: -------------------------------------------------------------------------------- 1 | name: text-plus 2 | version: 0.1.0.1 3 | synopsis: Utils for text 4 | description: Utils for text 5 | homepage: https://github.com/factisresearch/opensource#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: factis research GmbH 9 | maintainer: kieran.meinhardt@gmail.com 10 | copyright: 2017 factis research GmbH 11 | category: Data 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Data.Text.Plus 19 | build-depends: base >= 4.7 && < 5 20 | , QuickCheck 21 | , bytestring 22 | , pretty 23 | , strict-data 24 | , text 25 | , util-plus 26 | default-language: Haskell2010 27 | 28 | test-suite text-plus-test 29 | type: exitcode-stdio-1.0 30 | hs-source-dirs: test 31 | main-is: Spec.hs 32 | other-modules: Data.Text.PlusSpec 33 | build-depends: base 34 | , HTF 35 | , doctest 36 | , text 37 | , text-plus 38 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 39 | default-language: Haskell2010 40 | 41 | source-repository head 42 | type: git 43 | location: https://github.com/factisresearch/opensource.git 44 | -------------------------------------------------------------------------------- /util-plus/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright factis research GmbH (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alexander Thiemann nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /util-plus/README.md: -------------------------------------------------------------------------------- 1 | # A collection of commonly used utils 2 | 3 | [![CircleCI](https://circleci.com/gh/factisresearch/opensource-mono.svg?style=svg)](https://circleci.com/gh/factisresearch/opensource-mono) 4 | 5 | This package contains utility functions for data types of basic libraries and common general purpose combinators. 6 | -------------------------------------------------------------------------------- /util-plus/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /util-plus/src/Control/Applicative/Plus.hs: -------------------------------------------------------------------------------- 1 | module Control.Applicative.Plus 2 | ( withOptional 3 | , optional' 4 | , module Control.Applicative 5 | ) 6 | where 7 | 8 | import Control.Applicative 9 | import Control.Monad 10 | import qualified Data.Foldable as F 11 | 12 | {-# SPECIALIZE 13 | withOptional :: (a -> (b -> m c) -> m c) -> Maybe a -> (Maybe b -> m c) -> m c 14 | #-} 15 | withOptional :: 16 | (Foldable t, Alternative t) 17 | => (a -> (b -> m c) -> m c) 18 | -> t a 19 | -> (t b -> m c) 20 | -> m c 21 | withOptional withReq wrappedVal go = 22 | do let runAction = 23 | flip fmap wrappedVal $ \val -> 24 | withReq val $ \inner -> go (pure inner) 25 | emptyCase = go empty 26 | actionOrEmptyCase = 27 | F.foldl' (\_ a -> a) emptyCase runAction 28 | actionOrEmptyCase 29 | 30 | -- | A generalized version of 'optional' that works with 'Option' for example 31 | optional' :: (MonadPlus t, Alternative f) => f a -> f (t a) 32 | optional' x = 33 | flip fmap (optional x) $ \val -> 34 | case val of 35 | Just ok -> pure ok 36 | Nothing -> empty 37 | -------------------------------------------------------------------------------- /util-plus/src/Data/List/Plus.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Data.List.Plus 4 | ( module Data.List 5 | , catMaybes 6 | , chunksOf 7 | , extractLast 8 | , groupOn 9 | , groupOn' 10 | , groupOnSort 11 | , groupOnSort' 12 | , groupBySort 13 | , groupUnsortedOn 14 | , headM 15 | , lastElems 16 | , lastM 17 | , lookupM 18 | , makeMapping 19 | , mapMaybe 20 | , maximumM 21 | , merge 22 | , middle 23 | , minimumM 24 | , monotone 25 | , nubMerge 26 | , prefixesAndSuffixes 27 | , sconcatBy 28 | , spanTailRec 29 | , stripSuffix 30 | , tryStripPrefix 31 | , ungroupMay 32 | , withLast 33 | ) 34 | where 35 | 36 | import Safe.Plus 37 | 38 | import Control.Arrow (first, second) 39 | import Data.Function 40 | import Data.Hashable (Hashable) 41 | import Data.List 42 | import Data.Maybe (mapMaybe, catMaybes) 43 | import qualified Data.Foldable as F 44 | import qualified Data.HashSet as HashSet 45 | import qualified Data.List as L 46 | import qualified Data.List.NonEmpty as NL 47 | import qualified Data.Semigroup as S 48 | 49 | -- | Computes the element in the middle of the list 50 | -- If the list has an even number of elements, you will get the element after the middle of the 51 | -- list. 52 | middle :: [a] -> Maybe a 53 | middle xs = 54 | case drop (length xs `div` 2) xs of 55 | [] -> Nothing 56 | x:_ -> Just x 57 | 58 | -- O(n) requires a list sorted by the group key 59 | groupOn :: Eq b => (a -> b) -> [a] -> [(b,[a])] 60 | groupOn _ [] = [] 61 | groupOn proj (x:xs) = (x', (x:ys)) : groupOn proj zs 62 | where 63 | x' = proj x 64 | (ys,zs) = span ((==x') . proj) xs 65 | 66 | -- First sort and then group the list 67 | groupOnSort :: Ord b => (a -> b) -> [a] -> [(b,[a])] 68 | groupOnSort proj = groupOn proj . L.sortOn proj 69 | 70 | -- First sort and then group the list 71 | groupBySort :: Ord b => (b -> b -> Ordering) -> (a -> b) -> [a] -> [(b,[a])] 72 | groupBySort cmp proj = groupOn proj . L.sortBy (\x y -> cmp (proj x) (proj y)) 73 | 74 | -- O(n^2) 75 | -- Group the list, but don't sort it 76 | groupUnsortedOn :: forall a b. Eq b => (a -> b) -> [a] -> [(b, [a])] 77 | groupUnsortedOn proj = 78 | L.foldl' (addToGroups) [] 79 | where 80 | addToGroups :: [(b, [a])] -> a -> [(b, [a])] 81 | addToGroups m val = 82 | let key = proj val 83 | in case break ((== key) . fst) m of 84 | (_, []) -> m ++ [(key, [val])] 85 | (p, f:r) -> p ++ [(fst f, snd f ++ [val])] ++ r 86 | 87 | -- O(n) requires a list sorted by the group key 88 | groupOn' :: Eq b => (a -> (b,c)) -> [a] -> [(b,[c])] 89 | groupOn' proj = map (second (map (snd . proj))) . groupOn (fst . proj) 90 | 91 | groupOnSort' :: Ord b => (a -> (b,c)) -> [a] -> [(b,[c])] 92 | groupOnSort' proj = groupOn' proj . L.sortOn (fst . proj) 93 | 94 | sconcatBy :: (Ord b, Foldable f, S.Semigroup s) => (a -> b) -> (a -> s) -> f a -> [(b,s)] 95 | sconcatBy p1 p2 = 96 | fmap proj 97 | . NL.groupBy ((==) `on` p1) 98 | . L.sortOn p1 99 | . F.toList 100 | where 101 | proj gr = (p1 $ NL.head gr, S.sconcat $ NL.map p2 gr) 102 | 103 | extractLast :: a -> [a] -> ([a], a) 104 | extractLast x xs = 105 | case reverse xs of 106 | [] -> ([], x) 107 | y:ys -> (x : reverse ys, y) 108 | 109 | lastElems :: Int -> [a] -> [a] 110 | lastElems n = 111 | reverse . take n . reverse 112 | 113 | headM :: Monad m => [a] -> m a 114 | headM xs = 115 | case xs of 116 | [] -> safeFail "Cannot compute head of empty list" 117 | x:_ -> return x 118 | 119 | lastM :: Monad m => [a] -> m a 120 | lastM xs = 121 | case xs of 122 | [] -> safeFail "Cannot compute last of empty list" 123 | x:[] -> return x 124 | _:xs -> lastM xs 125 | 126 | withLast :: (a -> a) -> [a] -> [a] 127 | withLast _ [] = [] 128 | withLast f [x] = [f x] 129 | withLast f (x:xs) = x : withLast f xs 130 | 131 | minimumM :: (Monad m, Ord a) => [a] -> m a 132 | minimumM xs = 133 | case xs of 134 | [] -> safeFail "Cannot compute minimum of empty list" 135 | y:ys -> return $ L.foldl' min y ys 136 | 137 | maximumM :: (Monad m, Ord a) => [a] -> m a 138 | maximumM xs = 139 | case xs of 140 | [] -> safeFail "Connot compute maximum of empty list" 141 | y:ys -> return $ L.foldl' max y ys 142 | 143 | lookupM :: (Eq a, Monad m) => (a -> String) -> a -> [(a,b)] -> m b 144 | lookupM str x xs = 145 | case lookup x xs of 146 | Nothing -> 147 | safeFail ("Lookup of " ++ str x ++ " failed. Valid values are: " 148 | ++ show (map (str . fst) xs)) 149 | Just a -> 150 | return a 151 | 152 | ungroupMay :: [(a,[b])] -> Maybe [(a,b)] 153 | ungroupMay [] = Just [] 154 | ungroupMay ((_,[]):_) = Nothing 155 | ungroupMay ((a,bs):rest) = 156 | do r <- ungroupMay rest 157 | return (map ((,) a) bs ++ r) 158 | 159 | -- Returns false if and only if there are elements in decreasing order in the list. 160 | monotone :: (Ord a) => [a] -> Bool 161 | monotone (x0:x1:xs) 162 | | x0 <= x1 = monotone (x1:xs) 163 | | otherwise = False 164 | monotone _ = True 165 | 166 | -- makeMapping takes a list of pairs and create a list of key-value pairs 167 | -- such that each key appears only once in the result list. Moreover, 168 | -- the result list contains the pairs in the same order as the input list. 169 | -- Example: [(k1, v1), (k2, v2), (k1, v3)] --> [(k2, v2), (k1, v3)] 170 | makeMapping :: (Eq a, Hashable a) => [(a, b)] -> [(a, b)] 171 | makeMapping l = 172 | go (reverse l) HashSet.empty [] 173 | where 174 | go [] _ acc = acc 175 | go (x@(k, _) : xs) done acc = 176 | if k `HashSet.member` done 177 | then go xs done acc 178 | else go xs (HashSet.insert k done) (x:acc) 179 | 180 | -- | Merge two sorted list so that the resulting list is sorted as well. 181 | -- and contains all elements from one of the lists. 182 | -- The length of the resulting list is the sum of the lengths of the given lists. 183 | merge :: Ord a => [a] -> [a] -> [a] 184 | merge [] ys = ys 185 | merge xs [] = xs 186 | merge (x:xs) (y:ys) 187 | | x == y = x:y:(merge xs ys) 188 | | x < y = x:(merge xs (y:ys)) 189 | | otherwise = y:(merge (x:xs) ys) 190 | 191 | -- | Merge the two sorted lists and remove all duplicates. 192 | nubMerge :: Ord a => [a] -> [a] -> [a] 193 | nubMerge xs ys = nubSorted $ merge xs ys 194 | where 195 | nubSorted :: Ord a => [a] -> [a] 196 | nubSorted = foldr consUniqSorted [] 197 | 198 | consUniqSorted :: Ord a => a -> [a] -> [a] 199 | consUniqSorted x [] = [x] 200 | consUniqSorted x ys@(y:_) | x == y = ys 201 | | otherwise = x:ys 202 | 203 | chunksOf :: Int -> [a] -> [[a]] 204 | chunksOf n xs = 205 | case splitAt n xs of 206 | ([], _) -> [] 207 | (first, rest) -> first : chunksOf n rest 208 | 209 | stripSuffix :: (Eq a) => [a] -> [a] -> Maybe [a] 210 | stripSuffix s = (fmap reverse) . L.stripPrefix (reverse s) . reverse 211 | 212 | prefixesAndSuffixes :: [a] -> [([a],[a])] 213 | prefixesAndSuffixes a = 214 | case a of 215 | [] -> [([], [])] 216 | (a : r) -> ([], a : r) : map (first (a:)) (prefixesAndSuffixes r) 217 | 218 | -- | Strips as elements of a given prefix list as possible. Stops stripping 219 | -- if the prefix doesn't match anymore or is exhausted and returns the remaining 220 | -- string. 221 | tryStripPrefix :: Eq a => [a] -> [a] -> [a] 222 | tryStripPrefix [] xs = xs 223 | tryStripPrefix _ [] = [] 224 | tryStripPrefix (x:xs) yys@(y:ys) 225 | | x == y = tryStripPrefix xs ys 226 | | otherwise = yys 227 | 228 | spanTailRec :: (a -> Bool) -> [a] -> ([a], [a]) 229 | spanTailRec p xs = go ([], xs) 230 | where go (xs,[]) = (reverse xs, []) 231 | go (xs,(y:ys)) 232 | | p y = go (y : xs, ys) 233 | | otherwise = (reverse xs, y:ys) 234 | -------------------------------------------------------------------------------- /util-plus/src/GHC/Stack/Plus.hs: -------------------------------------------------------------------------------- 1 | {-| Helper functions for dealing with call stacks and source locations. 2 | -} 3 | module GHC.Stack.Plus 4 | ( callerLocation 5 | , callerFile 6 | , callerLine 7 | , adjustSourceFilePath 8 | ) 9 | where 10 | 11 | import GHC.Stack 12 | import Safe (tailSafe, lastNote) 13 | 14 | adjustSourceFilePath :: FilePath -> FilePath 15 | adjustSourceFilePath = tailSafe . dropWhile (/='/') . drop 1 . dropWhile (/= '/') 16 | 17 | callerLocation :: (HasCallStack) => String 18 | callerLocation = callerFile ++ ":" ++ show callerLine 19 | 20 | -- | The filename of the first caller which called a function with implicit 21 | -- parameter @(callStack :: 'CallStack')@. 22 | callerFile :: (HasCallStack) => String 23 | callerFile = srcLocFile . callerSrcLoc $ callStack 24 | 25 | -- | The line number of the first caller which called a function with 26 | -- implicit parameter @(callStack :: 'CallStack')@. 27 | callerLine :: (HasCallStack) => Int 28 | callerLine = srcLocStartLine . callerSrcLoc $ callStack 29 | 30 | callerSrcLoc :: CallStack -> SrcLoc 31 | callerSrcLoc = snd . caller 32 | 33 | caller :: CallStack -> (String, SrcLoc) 34 | caller = lastNote "Empty CallStack?!" . getCallStack 35 | -------------------------------------------------------------------------------- /util-plus/src/Safe/Plus.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | module Safe.Plus 3 | ( callerFile 4 | , callerLine 5 | , callerLocation 6 | , safeDigitToInt 7 | , safeRead 8 | , readNoteVerbose 9 | , safeFromJust 10 | , safeFromJustNote 11 | , safeHead 12 | , safeTail 13 | , safeInit 14 | , safeLast 15 | , safeMaximum 16 | , safeMinimum 17 | , safeHeadNote 18 | , safeFromRight 19 | , fromRightNote 20 | , safeFromLeft 21 | , fromLeftNote 22 | , safeAtArray 23 | , atArrayNote 24 | , safeAt 25 | , safeError 26 | , safeFail 27 | , safeUndef 28 | ) 29 | where 30 | 31 | import Data.Array.IArray 32 | import Data.Char 33 | import Data.Monoid 34 | import GHC.Stack 35 | import GHC.Stack.Plus 36 | import Safe 37 | 38 | -- | Convert a single digit 'Char' to the corresponding 'Int'. 39 | -- This function fails unless its argument satisfies 'isHexDigit', 40 | -- but recognises both upper and lower-case hexadecimal digits 41 | -- (i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@). 42 | safeDigitToInt :: Monad m => Char -> m Int 43 | safeDigitToInt c 44 | | isDigit c = return $ ord c - ord '0' 45 | | c >= 'a' && c <= 'f' = return $ ord c - ord 'a' + 10 46 | | c >= 'A' && c <= 'F' = return $ ord c - ord 'A' + 10 47 | | otherwise = safeFail ("Char.safeDigitToInt: not a digit " ++ show c) 48 | 49 | safeUndef :: (HasCallStack) => a 50 | safeUndef = safeError "undefined!" 51 | 52 | safeRead :: (HasCallStack, Read a) => String -> a 53 | safeRead = readNoteVerbose callerLocation 54 | 55 | readNoteVerbose :: Read a => String -> String -> a 56 | readNoteVerbose msg s = 57 | case [x | (x,t) <- reads s, ("","") <- lex t] of 58 | [x] -> x 59 | [] -> error $ "Prelude.read: no parse, " ++ msg ++ ", on " ++ prefix 60 | _ -> error $ "Prelude.read: ambiguous parse, " ++ msg ++ ", on " ++ prefix 61 | where 62 | prefix = '\"' : a ++ if null b then "\"" else "..." 63 | where (a,b) = splitAt 1024 s 64 | 65 | safeFromJust :: (HasCallStack) => Maybe a -> a 66 | safeFromJust = Safe.fromJustNote callerLocation 67 | 68 | safeFromJustNote :: (HasCallStack) => String -> Maybe a -> a 69 | safeFromJustNote s = Safe.fromJustNote (callerLocation ++ ": " ++ s) 70 | 71 | safeFail :: (HasCallStack, Monad m) => String -> m a 72 | safeFail x = fail (callerLocation ++ ": FAIL: " ++ x) 73 | 74 | safeHead :: (HasCallStack) => [a] -> a 75 | safeHead = Safe.headNote callerLocation 76 | 77 | safeTail :: (HasCallStack) => [a] -> [a] 78 | safeTail = Safe.tailNote callerLocation 79 | 80 | safeInit :: (HasCallStack) => [a] -> [a] 81 | safeInit = Safe.initNote callerLocation 82 | 83 | safeLast :: (HasCallStack) => [a] -> a 84 | safeLast = Safe.lastNote callerLocation 85 | 86 | safeMaximum :: (HasCallStack, Ord a) => [a] -> a 87 | safeMaximum = Safe.maximumNote callerLocation 88 | 89 | safeMinimum :: (HasCallStack, Ord a) => [a] -> a 90 | safeMinimum = Safe.minimumNote callerLocation 91 | 92 | safeHeadNote :: (HasCallStack) => String -> [a] -> a 93 | safeHeadNote x = Safe.headNote (callerLocation ++ ": " ++ x) 94 | 95 | safeFromRight :: (HasCallStack) => Either a b -> b 96 | safeFromRight = fromRightNote callerLocation 97 | 98 | fromRightNote :: String -> Either a b -> b 99 | fromRightNote msg (Left _) = error $ "fromRight got a left value: " ++ msg 100 | fromRightNote _ (Right x) = x 101 | 102 | safeFromLeft :: (HasCallStack) => Either a b -> a 103 | safeFromLeft = fromLeftNote callerLocation 104 | 105 | fromLeftNote :: String -> Either a b -> a 106 | fromLeftNote msg (Right _) = safeError $ "fromLeft got a right value: " ++ msg 107 | fromLeftNote _ (Left x) = x 108 | 109 | safeAtArray :: (HasCallStack, IArray a e, Ix i, Show i) => a i e -> i -> e 110 | safeAtArray = atArrayNote callerLocation 111 | 112 | atArrayNote :: (IArray a e, Ix i, Show i) => String -> a i e -> i -> e 113 | atArrayNote msg array index 114 | | inRange arrayBounds index = array ! index 115 | | otherwise = 116 | error $ concat 117 | [ "lookup at index ", show index, " in an array was outside of its bounds " 118 | , show arrayBounds, ": ", msg 119 | ] 120 | where 121 | arrayBounds = bounds array 122 | 123 | safeAt :: (HasCallStack) => [a] -> Int -> a 124 | safeAt = Safe.atNote callerLocation 125 | 126 | safeError :: (HasCallStack) => String -> a 127 | safeError err = error $ callerLocation <> ": " <> err 128 | -------------------------------------------------------------------------------- /util-plus/test/Data/List/PlusSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp -fno-warn-type-defaults #-} 2 | module Data.List.PlusSpec 3 | ( htf_thisModulesTests 4 | ) 5 | where 6 | 7 | import Data.List.Plus 8 | import Test.Framework 9 | import Test.QuickCheck.Function 10 | import qualified Data.List.Plus as L 11 | import qualified Data.Map.Strict as Map 12 | import qualified Data.Set as Set 13 | 14 | prop_spanTailRec :: Fun Int Bool -> [Int] -> Bool 15 | prop_spanTailRec (Fun _ f) lst = L.span f lst == spanTailRec f lst 16 | 17 | test_middle :: IO () 18 | test_middle = 19 | do assertNothing (middle ([] :: [Int])) 20 | assertEqual (Just 1) (middle [1]) 21 | assertEqual (Just 2) (middle [1,2]) 22 | assertEqual (Just 2) (middle [1,2,3]) 23 | assertEqual (Just 3) (middle [1,2,3,4]) 24 | 25 | test_tryStripPrefix :: IO () 26 | test_tryStripPrefix = 27 | do assertEqual "foobar" (tryStripPrefix "" "foobar") 28 | assertEqual "" (tryStripPrefix "foobar" "") 29 | assertEqual "z" (tryStripPrefix "foobar" "foobaz") 30 | assertEqual "baz" (tryStripPrefix "foobar" "foobarbaz") 31 | assertEqual "" (tryStripPrefix "foobarbaz" "foobar") 32 | 33 | test_groupUnsortedOn :: IO () 34 | test_groupUnsortedOn = 35 | do assertEqual [] $ groupUnsortedOn id ([] :: [()]) 36 | assertEqual [((), [()])] $ groupUnsortedOn id [()] 37 | assertEqual [((), [(), ()])] $ groupUnsortedOn id [(), ()] 38 | assertEqual [(1, [1]), (0, [2])] $ groupUnsortedOn (`mod` 2) [1, 2] 39 | assertEqual [(0, [2]), (1, [1])] $ groupUnsortedOn (`mod` 2) [2, 1] 40 | assertEqual [(1, [1, 3]), (0, [2, 4])] $ groupUnsortedOn (`mod` 2) [1, 2, 3, 4] 41 | assertEqual [(1, [1, 3]), (0, [2, 4])] $ groupUnsortedOn (`mod` 2) [1, 2, 4, 3] 42 | assertEqual [(0, [2, 4]), (1, [1, 3])] $ groupUnsortedOn (`mod` 2) [2, 1, 4, 3] 43 | 44 | test_groupOnSort :: IO () 45 | test_groupOnSort = 46 | do assertEqual [] $ groupOnSort id ([] :: [()]) 47 | assertEqual [((), [()])] $ groupOnSort id [()] 48 | assertEqual [((), [(), ()])] $ groupOnSort id [(), ()] 49 | assertEqual [(0, [2]), (1, [1])] $ groupOnSort (`mod` 2) [1, 2] 50 | assertEqual [(0, [2]), (1, [1])] $ groupOnSort (`mod` 2) [2, 1] 51 | assertEqual [(0, [2, 4]), (1, [1, 3])] $ groupOnSort (`mod` 2) [1, 2, 3, 4] 52 | assertEqual [(0, [2, 4]), (1, [1, 3])] $ groupOnSort (`mod` 2) [1, 2, 4, 3] 53 | assertEqual [(0, [2, 4]), (1, [1, 3])] $ groupOnSort (`mod` 2) [2, 1, 4, 3] 54 | 55 | test_headM :: IO () 56 | test_headM = 57 | do assertEqual Nothing $ headM ([] :: [()]) 58 | assertEqual (Just ()) $ headM [()] 59 | assertEqual (Just 1) $ headM [1,2] 60 | 61 | test_lastM :: IO () 62 | test_lastM = 63 | do assertEqual Nothing $ lastM ([] :: [()]) 64 | assertEqual (Just ()) $ lastM [()] 65 | assertEqual (Just 2) $ lastM [1,2] 66 | 67 | test_minimumM :: IO () 68 | test_minimumM = 69 | do assertEqual Nothing $ minimumM ([] :: [Int]) 70 | assertEqual (Just 1) $ minimumM [1] 71 | assertEqual (Just 1) $ minimumM [1,2] 72 | assertEqual (Just 1) $ minimumM [2,1] 73 | assertEqual (Just 1) $ minimumM [2,1,2] 74 | 75 | test_maximumM :: IO () 76 | test_maximumM = 77 | do assertEqual Nothing $ maximumM ([] :: [Int]) 78 | assertEqual (Just 2) $ maximumM [2] 79 | assertEqual (Just 2) $ maximumM [2,1] 80 | assertEqual (Just 2) $ maximumM [1,2] 81 | assertEqual (Just 2) $ maximumM [1,2,1] 82 | 83 | test_merge :: IO () 84 | test_merge = 85 | do assertEqual [1, 2, 3, 4, 5] $ nubMerge as bs 86 | assertEqual [] $ nubMerge empty empty 87 | assertEqual [1] $ nubMerge one empty 88 | assertEqual [1] $ nubMerge empty one 89 | assertEqual [1, 2, 3] $ nubMerge cs cs 90 | assertEqual [1, 2, 3, 4, 5, 6] $ nubMerge cs ds 91 | assertEqual [1, 2, 3, 4, 5, 6] $ nubMerge es fs 92 | assertEqual [1] $ nubMerge two one 93 | assertEqual [1] $ nubMerge one two 94 | assertEqual [1] $ nubMerge three empty 95 | assertEqual [1] $ nubMerge empty three 96 | 97 | assertEqual [1, 2, 2, 3, 4, 4, 5] $ merge as bs 98 | assertEqual [] $ merge empty empty 99 | assertEqual [1] $ merge one empty 100 | assertEqual [1] $ merge empty one 101 | assertEqual [1, 1, 2, 2, 3, 3] $ merge cs cs 102 | assertEqual [1, 2, 3, 4, 5, 6] $ merge cs ds 103 | assertEqual [1, 2, 3, 4, 5, 6] $ merge es fs 104 | assertEqual [1, 1, 1] $ merge two one 105 | assertEqual [1, 1, 1] $ merge one two 106 | assertEqual [1, 1, 1] $ merge three empty 107 | assertEqual [1, 1, 1] $ merge empty three 108 | where 109 | empty, one, two, three, as, bs, cs, ds, es, fs :: [Int] 110 | as = [1, 2, 3, 4] 111 | bs = [2, 4, 5] 112 | cs = [1, 2, 3] 113 | ds = [4, 5, 6] 114 | es = [1, 3, 5] 115 | fs = [2, 4, 6] 116 | empty = [] 117 | one = [1] 118 | two = [1, 1] 119 | three = [1, 1, 1] 120 | 121 | 122 | test_ungroup :: IO () 123 | test_ungroup = 124 | assertEqual (Just [("a","1"),("a","2"),("a","3"),("b","4")]) 125 | $ ungroupMay [("a",["1","2","3"]),("b",["4"])] 126 | 127 | test_ungroupGroup :: IO () 128 | test_ungroupGroup = 129 | do let list = [("x","1"),("y","1"),("y","3"),("y","1")] 130 | assertEqual (Just list) (ungroupMay $ groupOn' id list) 131 | 132 | test_stripSuffix :: IO () 133 | test_stripSuffix = 134 | do assertEqual (Just "foo") $ stripSuffix "bar" "foobar" 135 | assertEqual (Just "") $ stripSuffix "bar" "bar" 136 | assertEqual Nothing $ stripSuffix "bar" "foobars" 137 | 138 | test_monotone :: IO () 139 | test_monotone = 140 | do assertEqual True $ monotone [1,2,3] 141 | assertEqual False $ monotone [-1,0,3,2] 142 | assertEqual True $ monotone [1] 143 | assertEqual True $ monotone ([] :: [Int]) 144 | 145 | test_lastElems :: IO () 146 | test_lastElems = 147 | do assertEqual ([]::[Int]) (lastElems 100 []) 148 | assertEqual [1,2,3] (lastElems 5 [1,2,3]) 149 | assertEqual [1,2,3] (lastElems 3 [1,2,3]) 150 | assertEqual [2,3] (lastElems 2 [1,2,3]) 151 | 152 | 153 | prop_lastElems :: [Int] -> Int -> Bool 154 | prop_lastElems l n = 155 | lastElems n l `L.isSuffixOf` l 156 | 157 | test_makeMapping :: IO () 158 | test_makeMapping = 159 | do assertEqual [] (makeMapping ([]::[(Int, String)])) 160 | let l = [(1::Int, "one"), (2, "two")] in assertEqual l (makeMapping l) 161 | assertEqual [(2::Int, "two"), (1, "three")] 162 | (makeMapping [(1, "one"), (2, "two"), (1, "three")]) 163 | assertEqual [(1::Int, "x")] (makeMapping [(1,"x"),(1,"x")]) 164 | let l2 = [(-2,""),(-2,"a"),(-2,"")] 165 | assertBool $ checkOrder (makeMapping l2) l2 166 | 167 | test_chunksOf :: IO () 168 | test_chunksOf = 169 | do assertEqual [] (chunksOf 1 ([] :: [Int])) 170 | assertEqual [] (chunksOf 0 [1]) 171 | assertEqual [[1], [2], [3], [4]] (chunksOf 1 [1, 2, 3, 4]) 172 | assertEqual [[1, 2], [3, 4]] (chunksOf 2 [1, 2, 3, 4]) 173 | assertEqual [[1, 2], [3]] (chunksOf 2 [1, 2, 3]) 174 | assertEqual [[1, 2, 3]] (chunksOf 3 [1, 2, 3]) 175 | 176 | test_prefixesAndSuffixes :: IO () 177 | test_prefixesAndSuffixes = 178 | do assertEqual (prefixesAndSuffixes "") [("","")] 179 | assertEqual (prefixesAndSuffixes "Hallo") 180 | [("","Hallo"), ("H","allo"),("Ha","llo"),("Hal","lo"),("Hall","o"),("Hallo","")] 181 | 182 | prop_makeMappingConcat :: [(Int, String)] -> Bool 183 | prop_makeMappingConcat l = 184 | makeMapping l == makeMapping (l ++ l) 185 | 186 | prop_makeMappingKeysUnique :: [(Int, String)] -> Bool 187 | prop_makeMappingKeysUnique l = 188 | length (map fst (makeMapping l)) == Set.size (Set.fromList (map fst l)) 189 | 190 | prop_makeMappingKeyValsOk :: [(Int, String)] -> Bool 191 | prop_makeMappingKeyValsOk l = 192 | Map.fromList (makeMapping l) == Map.fromList l 193 | 194 | prop_makeMappingOrderingOk :: [(Int, String)] -> Bool 195 | prop_makeMappingOrderingOk l = 196 | checkOrder (makeMapping l) l 197 | 198 | checkOrder :: [(Int, String)] -> [(Int, String)] -> Bool 199 | checkOrder [] [] = True 200 | checkOrder (x:xs) (y:ys) 201 | | x == y = checkOrder xs (dropWhile ((fst x ==) . fst) ys) 202 | | otherwise = checkOrder (x:xs) ys 203 | checkOrder _ _ = False 204 | 205 | test_withLast :: IO () 206 | test_withLast = 207 | do assertEqual [] (withLast not []) 208 | assertEqual [False] (withLast not [True]) 209 | assertEqual [True,False] (withLast not [True,True]) 210 | -------------------------------------------------------------------------------- /util-plus/test/GHC/Stack/PlusSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module GHC.Stack.PlusSpec 3 | ( htf_thisModulesTests 4 | ) 5 | where 6 | 7 | import GHC.Stack.Plus 8 | import Test.Framework 9 | 10 | test_callerSrcLoc :: IO () 11 | test_callerSrcLoc = 12 | do assertEqual __FILE__ callerFile 13 | assertEqual __LINE__ callerLine 14 | -------------------------------------------------------------------------------- /util-plus/test/Safe/PlusSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Safe.PlusSpec where 3 | 4 | import GHC.Exception 5 | import Safe.Plus 6 | import Test.Framework 7 | 8 | test_safeError :: IO () 9 | test_safeError = 10 | assertThrows (safeError msg) (matches (format __FILE__ __LINE__)) 11 | where 12 | matches expected (ErrorCallWithLocation actual _) = expected == actual 13 | format :: String -> Int -> String 14 | format file line = file ++ ":" ++ show line ++ ": " ++ msg 15 | msg = "error message" 16 | -------------------------------------------------------------------------------- /util-plus/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module Main where 3 | 4 | import {-@ HTF_TESTS @-} Data.List.PlusSpec 5 | import {-@ HTF_TESTS @-} GHC.Stack.PlusSpec 6 | import {-@ HTF_TESTS @-} Safe.PlusSpec 7 | 8 | import Test.Framework 9 | 10 | main :: IO () 11 | main = htfMain htf_importedTests 12 | -------------------------------------------------------------------------------- /util-plus/util-plus.cabal: -------------------------------------------------------------------------------- 1 | name: util-plus 2 | version: 0.1.0.0 3 | synopsis: A collection of commonly used utils 4 | description: A collection of commonly used util functions for basic libaries 5 | homepage: https://github.com/factisresearch/opensource#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: factis research GmbH 9 | maintainer: mail@athiemann.net 10 | copyright: 2017 factis research GmbH 11 | category: Data 12 | build-type: Simple 13 | extra-source-files: 14 | README.md 15 | cabal-version: >=1.10 16 | 17 | library 18 | hs-source-dirs: src 19 | exposed-modules: GHC.Stack.Plus 20 | , Safe.Plus 21 | , Data.List.Plus 22 | , Control.Applicative.Plus 23 | build-depends: base >= 4.7 && < 5 24 | , safe 25 | , array 26 | , hashable 27 | , containers 28 | , unordered-containers 29 | default-language: Haskell2010 30 | ghc-options: -Wall 31 | 32 | test-suite util-plus-test 33 | type: exitcode-stdio-1.0 34 | hs-source-dirs: test 35 | main-is: Spec.hs 36 | other-modules: GHC.Stack.PlusSpec 37 | , Safe.PlusSpec 38 | , Data.List.PlusSpec 39 | build-depends: base >= 4.7 && < 5 40 | , HTF 41 | , QuickCheck 42 | , containers 43 | , util-plus 44 | ghc-options: -Wall 45 | default-language: Haskell2010 46 | 47 | source-repository head 48 | type: git 49 | location: https://github.com/factisresearch/opensource.git 50 | --------------------------------------------------------------------------------