Add tests and fix stuff accordingly

geode.cabal

@@ -22,11 +22,13 @@ extra-source-files: CHANGELOG.md
 
 library
     exposed-modules:  GEODE.Metadata
-                    , Options.GEODE
+                    , GEODE.Options
 
     -- Modules included in this library but not exported.
-    other-modules:    GEODE.Metadata.Article
+    other-modules:    GEODE.Metadata.Entry
+                    , GEODE.Metadata.PrimaryKey
                     , GEODE.Metadata.Projector
+                    , GEODE.Metadata.TSV
                     , GEODE.Metadata.Types
 
     -- LANGUAGE extensions used by modules in this package.
@@ -35,8 +37,24 @@ library
                     , bytestring >= 0.11.3 && <0.12
                     , containers >= 0.6.5.1 && <0.7
                     , cassava >= 0.5.3 && <0.6
+                    , filepath >= 1.4.2.2 && <1.5
                     , optparse-applicative >= 0.13.2 && < 0.18
                     , text >= 1.2.5 && <1.3
+                    , unordered-containers >= 0.2.19.1 && <0.3
                     , vector >= 0.12.3.1 && <0.13
     hs-source-dirs:   lib
     default-language: Haskell2010
+
+test-suite ghc-geode-test
+    default-language: Haskell2010
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          Main.hs
+    other-modules:    GEODE.Metadata.TestPrimaryKey
+                    , Test.HUnit.Extra
+    build-depends:    base
+                    , bytestring
+                    , cassava
+                    , geode
+                    , HUnit >= 1.6.2.0 && <1.7
+                    , unordered-containers

guix.scm

 (use-modules ((gnu packages haskell-xyz) #:select (ghc-cassava
                                                    ghc-optparse-applicative))
+             ((gnu packages haskell-check) #:select (ghc-hunit))
              ((guix build-system haskell) #:select (haskell-build-system))
              ((guix git-download) #:select (git-predicate))
              ((guix gexp) #:select (local-file))
@@ -16,7 +17,7 @@
           #:recursive? #t
           #:select? (git-predicate %source-dir)))
     (build-system haskell-build-system)
-    (inputs (list ghc-cassava ghc-optparse-applicative))
+    (inputs (list ghc-cassava ghc-optparse-applicative ghc-hunit))
     (home-page "https://gitlab.liris.cnrs.fr/geode/ghc-geode")
     (synopsis "Data structures and tooling used in project GEODE")
     (description

lib/GEODE/Metadata.hs

 {-# LANGUAGE NamedFieldPuns, OverloadedStrings #-}
 module GEODE.Metadata
-  ( module ID
+  ( module PrimaryKey
   , module Entry
   , module TSV
   , module Projector
@@ -14,7 +14,7 @@ import Data.Foldable as Foldable (toList)
 import Data.List (sortOn)
 import Data.Map.Strict as Map (Map, alter, empty, insert, toList)
 import Data.Text as Text (Text, intercalate, unpack)
-import GEODE.Metadata.ID as ID
+import GEODE.Metadata.PrimaryKey as PrimaryKey
 import GEODE.Metadata.Entry as Entry
 import GEODE.Metadata.Projector as Projector
 import GEODE.Metadata.TSV as TSV

lib/GEODE/Metadata/Entry.hs

+{-# LANGUAGE DeriveGeneric #-}
 module GEODE.Metadata.Entry
   ( Entry(..)
   , headerSection ) where
@@ -9,11 +10,11 @@ import GHC.Generics (Generic)
 
 data Entry = Entry
   { headWord :: Text
-  , rank :: Int 
+  , name :: Text 
   , page :: Int } deriving (Generic, Show)
 
 instance FromNamedRecord Entry
 instance ToNamedRecord Entry
 
 instance DefaultHeader Entry where
-  headerSection = Default [ "headWord", "rank", "page" ]
+  headerSection = Default [ "headWord", "name", "page" ]

lib/GEODE/Metadata/ID.hs

-module GEODE.Metadata.ID
-  ( HasID(..)
-  , ID
-  , book
-  , tome
-  , name
-  , headerSection
-  , relativePath
-  , uid ) where
-
-import Data.Csv (FromNamedRecord(..), ToNamedRecord(..))
-import Data.Text (Text, unpack)
-import GEODE.Metadata.Types (Book)
---import GEODE.Metadata.Projector (InFile(..), Unique(..))
-import GEODE.Metadata.TSV (Default(..), DefaultHeader(..))
-import GHC.Generics (Generic)
-import System.FilePath ((</>), (<.>))
-import Text.Printf (printf)
-
-data ID = ID
-  { book_ :: Book
-  , tome_ :: Int
-  , name_ :: Text } deriving (Eq, Ord, Generic, Show)
-
-class HasID t where
-  iD :: t -> ID
-
-instance HasID ID where
-  iD = id
-
-instance HasID (ID, a) where
-  iD = fst
-
-book :: HasID a => a -> Book
-book = book_ . iD
-
-tome :: HasID a => a -> Int
-tome = tome_ . iD
-
-name :: HasID a => a -> Text
-name = name_ . iD
-
-instance FromNamedRecord ID
-instance ToNamedRecord ID
-
-uid :: HasID a => a -> String
-uid a = printf "%s_%d_%s" (show $ book a) (tome a) (unpack $ name a)
-
-relativePath :: HasID a => a -> String -> FilePath
-relativePath a extension =
-  (show $ book a) </> (show $ tome a) </> (unpack $ name a) <.> extension
-
-{-
-instance Unique ID where
-  uid (ID {book, tome, name}) =
-    printf "%s_%d_%s" (show book) tome (unpack name)
-
-instance InFile ID where
-  relativePath (ID {book, tome, name}) extension =
-    show book </> show tome </> unpack name <.> extension
--}
-
-instance DefaultHeader ID where
-  headerSection = Default [ "book", "tome", "name" ]

lib/GEODE/Metadata/PrimaryKey.hs

+{-# LANGUAGE DeriveGeneric, FlexibleInstances, NamedFieldPuns #-}
+module GEODE.Metadata.PrimaryKey
+  ( HasPK(..)
+  , PrimaryKey(..)
+  , headerSection
+  , relativePath
+  , uid ) where
+
+import Data.Csv (FromNamedRecord(..), ToNamedRecord(..))
+import Data.Text (Text, unpack)
+import GEODE.Metadata.Types (Book)
+import GEODE.Metadata.TSV (Default(..), DefaultHeader(..))
+import GHC.Generics (Generic)
+import System.FilePath ((</>), (<.>))
+import Text.Printf (printf)
+
+data PrimaryKey = PrimaryKey
+  { book :: Book
+  , tome :: Int
+  , rank :: Int } deriving (Eq, Ord, Generic, Show)
+
+class HasPK t where
+  pKey :: t -> PrimaryKey
+
+instance HasPK PrimaryKey where
+  pKey = id
+
+instance HasPK (PrimaryKey, a) where
+  pKey = fst
+
+instance FromNamedRecord PrimaryKey
+instance ToNamedRecord PrimaryKey
+
+uid :: HasPK a => a -> String
+uid a = printf "%s_%d_%d" (show $ book) tome rank
+  where
+    PrimaryKey {book, tome, rank} = pKey a
+
+relativePath :: HasPK a => a -> String -> FilePath
+relativePath a extension =
+  (show book) </> (show tome) </> (show rank) <.> extension
+  where
+    PrimaryKey {book, tome, rank} = pKey a
+
+instance DefaultHeader PrimaryKey where
+  headerSection = Default [ "book", "tome", "rank" ]

lib/GEODE/Metadata/TSV.hs

-{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}
+{-# LANGUAGE DeriveGeneric, FlexibleInstances, ScopedTypeVariables, UndecidableInstances #-}
 module GEODE.Metadata.TSV
   ( Default(..)
   , DefaultHeader(..)
+  , Glue(..)
+  , Sections(..)
   , readNamedTsv
   , readTsv
   , toTsv
@@ -11,11 +13,11 @@ module GEODE.Metadata.TSV
 import Data.ByteString.Char8 as StrictByteString (pack)
 import Data.ByteString.Lazy as ByteString (putStr, readFile, writeFile)
 import Data.Csv
-  ( DecodeOptions(..), EncodeOptions(..), FromNamedRecord, FromRecord
+  ( DecodeOptions(..), EncodeOptions(..), FromNamedRecord(..), FromRecord
   , HasHeader(..), ToNamedRecord(..), ToRecord(..), decodeByNameWith, decodeWith
   , defaultEncodeOptions, encodeByNameWith, encodeWith, header )
 import Data.Foldable (toList)
-import Data.HashMap.Strict ((!))
+import Data.HashMap.Strict ((!), union)
 import Data.Vector (Vector, fromList)
 
 readNamedTsv :: FromNamedRecord a => FilePath -> IO (Either String (Vector a))
@@ -34,12 +36,30 @@ newtype Default a = Default { defaultHeader :: [String] }
 class DefaultHeader a where
   headerSection :: Default a
 
-instance (DefaultHeader a, DefaultHeader b) => DefaultHeader (a, b) where
+data Glue a b = Glue a b
+newtype Sections a = Sections a
+
+instance (DefaultHeader a, DefaultHeader b) => DefaultHeader (Glue a b) where
   headerSection = Default (a ++ b)
     where
       Default a = (headerSection :: Default a)
       Default b = (headerSection :: Default b)
 
+instance (DefaultHeader a, DefaultHeader b) => DefaultHeader (Sections (a, b)) where
+  headerSection = Default (a ++ b)
+    where
+      Default a = (headerSection :: Default a)
+      Default b = (headerSection :: Default b)
+
+instance (ToNamedRecord a, ToNamedRecord b) => ToNamedRecord (Glue a b) where
+  toNamedRecord (Glue a b) = union (toNamedRecord a) (toNamedRecord b)
+
+instance (ToNamedRecord a, ToNamedRecord b) => ToNamedRecord (Sections (a, b)) where
+  toNamedRecord (Sections (a, b)) = union (toNamedRecord a) (toNamedRecord b)
+
+instance (FromNamedRecord a, FromNamedRecord b) => FromNamedRecord (Glue a b) where
+  parseNamedRecord nr = Glue <$> parseNamedRecord nr <*> parseNamedRecord nr
+
 instance (DefaultHeader a, ToNamedRecord a) => ToRecord a where
   toRecord = fromList . prepare . toNamedRecord
     where

test/GEODE/Metadata/TestPrimaryKey.hs

+{-# LANGUAGE OverloadedStrings #-}
+module GEODE.Metadata.TestPrimaryKey (testPrimaryKey) where
+
+import Data.ByteString.Char8 as BS (pack)
+import Data.Csv (ToNamedRecord(..))
+import Data.HashMap.Strict ((!?))
+import GEODE.Metadata (Book(..), Default(..), DefaultHeader(..), PrimaryKey(..))
+import Test.HUnit (Test(..), (~?=))
+import Test.HUnit.Extra (isJust)
+
+testPrimaryKey :: Test
+testPrimaryKey = TestLabel "Testing the PrimaryKey data type" $
+  TestList [ testToNamedRecord ]
+
+testToNamedRecord :: Test
+testToNamedRecord = TestLabel "Testing ToNamedRecord instance" $
+  TestList [ has3Keys, validDefaultHeader ]
+  where
+    has3Keys = length aNamedRecord ~?= 3
+    validDefaultHeader =
+      TestList ((isJust . (aNamedRecord !?) . BS.pack) <$> defaultHeader)
+    aNamedRecord = toNamedRecord aPrimaryKey
+    Default defaultHeader = (headerSection :: Default PrimaryKey)
+
+aPrimaryKey :: PrimaryKey
+aPrimaryKey = PrimaryKey LGE 1 1212 -- ALCALA DE HÉNARÈS

test/Main.hs

+module Main (main) where
+
+import Test.HUnit (runTestTT, showCounts)
+import GEODE.Metadata.TestPrimaryKey (testPrimaryKey)
+
+main :: IO ()
+main = runTestTT testPrimaryKey >>= putStr . showCounts

test/Test/HUnit/Extra.hs

+module Test.HUnit.Extra
+  ( isJust
+  , isNothing ) where
+
+import Test.HUnit (Test(..), assertBool)
+import qualified Data.Maybe as Maybe (isJust, isNothing)
+
+isJust :: Maybe a -> Test
+isJust = TestCase . assertBool "Expected a Just" . Maybe.isJust
+
+isNothing :: Maybe a -> Test
+isNothing = TestCase . assertBool "Expected a Nothing" . Maybe.isNothing