Merge pull request #8 from danslapman/refactor/sequence

Use Data.Sequence instead of Deque

.github/workflows/ci.yml

@@ -28,7 +28,9 @@ jobs:
           stack-no-global: true
           enable-stack: true
           stack-version: 'latest'
+      - run: stack test
       - run: stack --local-bin-path target install
+        if: ${{ startsWith(github.ref, 'refs/tags/') }}
       - uses: svenstaro/upload-release-action@v2
         with:
           repo_token: ${{ secrets.GITHUB_TOKEN }}

.gitignore

@@ -1,3 +1,4 @@
+.vscode/
 dist
 dist-*
 cabal-dev
@@ -23,3 +24,4 @@ cabal.project.local~
 json2csv.cabal
 stack.yaml.lock
 */target/**
+.repos

app/Main.hs

@@ -13,15 +13,15 @@ import qualified Data.HashMap.Strict as HM
 import Data.HashSet (HashSet, empty, intersection, null, union)
 import qualified Data.HashSet as HS (toList)
 import Data.IORef
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq (fromList)
 import Data.Text (Text, intercalate)
 import qualified Data.Text.IO as TIO
-import Deque.Strict (Deque)
-import DequeUtils (uniq)
-import GHC.Exts (fromList)
 import Json2Csv
 import Options.Applicative hiding (empty)
 import Options.Applicative.Text
 import Schema
+import SequenceUtils (uniq)
 import System.IO
 import System.ProgressBar
 import Prelude hiding (foldl, foldl', map, null, sequence)
@@ -75,7 +75,7 @@ main = do
         (parseAndWriteEntry mkSepString flat schema columns hIn hOut)
         incProgress pb 1
 
-computeHeaderMultiline :: PathSetCombine -> Handle -> IO (Deque JsonPath, Int)
+computeHeaderMultiline :: PathSetCombine -> Handle -> IO (Seq JsonPath, Int)
 computeHeaderMultiline combine handle = do
   currentLineNumber <- newIORef (0 :: Int)
   pathSet <- newIORef (empty :: HashSet JsonPath)
@@ -90,9 +90,9 @@ computeHeaderMultiline combine handle = do
     modifyIORef' pathSet (combine header)
   pathes <- readIORef pathSet
   numberOfLines <- readIORef currentLineNumber
-  return (fromList . HS.toList $ pathes, numberOfLines)
+  return (Seq.fromList . HS.toList $ pathes, numberOfLines)
 
-parseAndWriteEntry :: (Deque Text -> Text) -> Bool -> JsonSchema -> Deque Text -> Handle -> Handle -> IO ()
+parseAndWriteEntry :: (Seq Text -> Text) -> Bool -> JsonSchema -> Seq Text -> Handle -> Handle -> IO ()
 parseAndWriteEntry mkSepString flat schema columns hIn hOut = do
   line <- LBS.fromStrict <$> BS.hGetLine hIn
   let (Just parsed) = decode line :: Maybe Value

opl.csv

@@ -0,0 +1,6 @@
+b.$.value;a
+field b2;field a0
+field b xxx;field a0
+field b1;field a1
+field b2;field a2
+field b xxx;field a2

package.yaml

@@ -26,11 +26,11 @@ dependencies:
 - bytestring
 - aeson
 - vector
+- containers
 - unordered-containers
 - lens
 - lens-aeson
 - monad-loops
-- deque
 - hashable
 - deepseq
 - optparse-applicative
@@ -68,3 +68,4 @@ tests:
     - -fwarn-unused-imports
     dependencies:
     - json2csv
+    - HUnit

src/Json2Csv.hs

@@ -7,17 +7,17 @@ import qualified Data.Aeson.Key as JK
 import qualified Data.Aeson.KeyMap as KM
 import Data.HashSet
 import Data.Maybe (mapMaybe)
+import Data.Sequence ((<|))
 import Data.Text (Text, pack)
 import qualified Data.Vector as V
-import Deque.Strict (cons)
 import HashSetUtils
 import Schema
 import TextShow hiding (singleton)
 import Prelude hiding (concatMap, foldl, join, map, null)
 
 prepend :: JsonPathElement -> HashSet JsonPath -> HashSet JsonPath
 prepend prefix s | null s = singleton $ pure prefix
-prepend prefix path = map (prefix `cons`) path
+prepend prefix path = map (prefix <|) path
 
 nonEmptyJ :: Value -> Bool
 nonEmptyJ Null = False

src/Schema.hs

@@ -15,13 +15,11 @@ import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.Hashable
 import Data.Maybe hiding (mapMaybe)
+import Data.Sequence
 import Data.Text (Text, intercalate)
 import Data.Typeable (Typeable)
-import Deque.Strict
-import DequePatterns
-import DequeUtils
-import GHC.Exts (fromList)
 import GHC.Generics (Generic)
+import SequenceUtils
 import Prelude hiding (any, foldl, foldl', head)
 
 data JsonPathElement
@@ -33,63 +31,63 @@ instance Hashable JsonPathElement
 
 instance NFData JsonPathElement
 
-type JsonPath = Deque JsonPathElement
+type JsonPath = Seq JsonPathElement
 
 data JsonSchemaTree
-  = PathNode JsonPathElement (Deque JsonSchemaTree)
+  = PathNode JsonPathElement (Seq JsonSchemaTree)
   | PathEnd
   deriving (Eq, Show, Typeable)
 
-type JsonSchema = Deque JsonSchemaTree
+type JsonSchema = Seq JsonSchemaTree
 
 hasSameRoot :: JsonPath -> JsonSchemaTree -> Bool
 hasSameRoot path tree = case (tree, path) of
-  (PathNode el _, h :|| _) | el == h -> True
+  (PathNode el _, h :<| _) | el == h -> True
   otherwise -> False
 
 toSchemaTree :: JsonPath -> JsonSchemaTree
 toSchemaTree =
   \case
-    D_ -> PathEnd
-    root :|| path -> PathNode root $ pure $ toSchemaTree path
+    Empty -> PathEnd
+    root :<| path -> PathNode root $ pure $ toSchemaTree path
 
 (#+) :: JsonSchema -> JsonPath -> JsonSchema
 (#+) schema path =
   let append path tree = case (tree, path) of
-        (t, D_) -> t
-        (PathNode el D_, h :|| tail)
+        (t, Empty) -> t
+        (PathNode el Empty, h :<| tail)
           | el == h ->
               PathNode el $ pure $ toSchemaTree tail
-        (PathNode el branches, h :|| tail)
+        (PathNode el branches, h :<| tail)
           | el == h ->
               PathNode el $ uniq $ branches #+ tail
         (PathEnd, path) -> toSchemaTree path
         (t, _) -> t
    in if any (hasSameRoot path) schema
         then append path <$> schema
-        else toSchemaTree path `snoc` schema
+        else schema |> toSchemaTree path
 
-toSchema :: Deque JsonPath -> JsonSchema
+toSchema :: Seq JsonPath -> JsonSchema
 toSchema = foldl' (#+) empty
 
 data JsonValueTree
-  = ValueRoot JsonPathElement (Deque JsonValueTree)
+  = ValueRoot JsonPathElement (Seq JsonValueTree)
   | SingleValue JsonPathElement Value
-  | ValueArray (Deque Value)
-  | TreeArray (Deque (Deque JsonValueTree))
+  | ValueArray (Seq Value)
+  | TreeArray (Seq (Seq JsonValueTree))
   deriving (Eq, Show, Typeable)
 
-type JsonTree = Deque JsonValueTree
+type JsonTree = Seq JsonValueTree
 
 extract :: JsonSchema -> Value -> JsonTree
 extract schema value =
   let extractTree v schemaTree =
         case schemaTree of
           PathEnd -> Nothing
-          (PathNode el (PathEnd :|| D_)) ->
+          (PathNode el (PathEnd :<| Empty)) ->
             case el of
               Key k -> SingleValue el <$> v ^? (key $ fromText k)
-              Iterator -> ValueArray <$> (maybeNeq $ fromList $ v ^.. values)
+              Iterator -> ValueArray <$> (maybeNes $ fromList $ v ^.. values)
           (PathNode el@(Key k) children) ->
             let keyValue = (v ^? (key $ fromText k))
                 childrenExtractors = flip extractTree <$> children
@@ -99,20 +97,20 @@ extract schema value =
             let nodeValues = fromList $ v ^.. values
                 childrenExtractors = flip extractTree <$> children
                 nodeTrees = (\val -> mapMaybe id $ ($ val) <$> childrenExtractors) <$> nodeValues
-             in TreeArray <$> maybeNeq nodeTrees
+             in TreeArray <$> maybeNes nodeTrees
    in mapMaybe id $ (extractTree value <$> schema)
 
-genMaps :: Bool -> JsonPath -> JsonValueTree -> Deque (HashMap Text Value)
+genMaps :: Bool -> JsonPath -> JsonValueTree -> Seq (HashMap Text Value)
 genMaps flat jp jvt =
   case (flat, jvt) of
-    (_, ValueRoot jpe trees) -> xfold $ genMaps flat (jpe `snoc` jp) <$> trees
-    (_, SingleValue jpe value) -> pure $ HM.singleton (jsonPathText $ jpe `snoc` jp) value
-    (False, ValueArray values) -> HM.singleton (jsonPathText (Iterator `snoc` jp)) <$> values
+    (_, ValueRoot jpe trees) -> xfold $ genMaps flat (jp |> jpe) <$> trees
+    (_, SingleValue jpe value) -> pure $ HM.singleton (jsonPathText $ jp |> jpe) value
+    (False, ValueArray values) -> HM.singleton (jsonPathText (jp |> Iterator)) <$> values
     (True, ValueArray values) -> HM.singleton (jsonPathText jp) <$> values
-    (False, TreeArray trees) -> trees >>= (xfold . (genMaps flat (Iterator `snoc` jp) <$>))
+    (False, TreeArray trees) -> trees >>= (xfold . (genMaps flat (jp |> Iterator) <$>))
     (True, TreeArray trees) -> trees >>= (xfold . (genMaps flat jp <$>))
 
-generateTuples :: Bool -> JsonTree -> Deque (HashMap Text Value)
+generateTuples :: Bool -> JsonTree -> Seq (HashMap Text Value)
 generateTuples flat jTree = xfold $ genMaps flat empty <$> jTree
 
 jsonPathText :: JsonPath -> Text
@@ -131,13 +129,13 @@ dropIterators jpath =
       Key k -> Just $ Key k
       Iterator -> Nothing
 
-xseq :: (a -> a -> a) -> Deque a -> Deque a -> Deque a
-xseq _ va D_ = va
-xseq _ D_ vb = vb
+xseq :: (a -> a -> a) -> Seq a -> Seq a -> Seq a
+xseq _ va Empty = va
+xseq _ Empty vb = vb
 xseq f va vb = do
   a <- va
   b <- vb
   return $ f a b
 
-xfold :: Deque (Deque (HashMap Text Value)) -> Deque (HashMap Text Value)
+xfold :: Seq (Seq (HashMap Text Value)) -> Seq (HashMap Text Value)
 xfold = foldl' (xseq HM.union) empty

src/SequenceUtils.hs

@@ -0,0 +1,18 @@
+module SequenceUtils where
+
+import Data.Foldable (find, toList)
+import qualified Data.List as L
+import qualified Data.Maybe as Mb (mapMaybe)
+import Data.Sequence
+import Prelude hiding (concat, elem, foldl, foldl', foldl1, mapM, null, (++))
+
+maybeNes :: Seq a -> Maybe (Seq a)
+maybeNes = find (not . null) . Just
+
+uniq :: Eq a => Seq a -> Seq a
+uniq = fromList . L.nub . toList
+
+mapMaybe :: (a -> Maybe b) -> Seq a -> Seq b
+mapMaybe _ Empty = empty
+mapMaybe pred dq =
+  fromList . Mb.mapMaybe pred . toList $ dq

test/Spec.hs

@@ -1,2 +1,4 @@
+import Test.HUnit
+
 main :: IO ()
 main = putStrLn "Test suite not yet implemented"