diff --git a/geode.cabal b/geode.cabal
index 721701067ad4482f6c963ece6ab35e260c118c4c..f88f1e36f1b2c088ad78e2271adf57a784cb5c72 100644
--- a/geode.cabal
+++ b/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
diff --git a/guix.scm b/guix.scm
index 1986f26f6f2179e0a7ba4ec60f2ef947c7f02548..64f4d5791bacfbe2a106433cd14cb3959f80beff 100644
--- a/guix.scm
+++ b/guix.scm
@@ -1,5 +1,6 @@
(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
diff --git a/lib/GEODE/Metadata.hs b/lib/GEODE/Metadata.hs
index 04b64178a5c4a1b18f7f266be6f03f096f586036..9eaeab858926f8ae9c6f14fc2798a9e5256a209a 100644
--- a/lib/GEODE/Metadata.hs
+++ b/lib/GEODE/Metadata.hs
@@ -1,6 +1,6 @@
{-# 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
diff --git a/lib/GEODE/Metadata/Entry.hs b/lib/GEODE/Metadata/Entry.hs
index 6e19a214d24ac12771d82a4200be5895be8e31c1..d34326eaaa433d931f9eab2fe568c8cbcb053eed 100644
--- a/lib/GEODE/Metadata/Entry.hs
+++ b/lib/GEODE/Metadata/Entry.hs
@@ -1,3 +1,4 @@
+{-# 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" ]
diff --git a/lib/GEODE/Metadata/ID.hs b/lib/GEODE/Metadata/ID.hs
deleted file mode 100644
index 2d9f1f82ce5f440cee64f687df460c871c9959ea..0000000000000000000000000000000000000000
--- a/lib/GEODE/Metadata/ID.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-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" ]
diff --git a/lib/GEODE/Metadata/PrimaryKey.hs b/lib/GEODE/Metadata/PrimaryKey.hs
new file mode 100644
index 0000000000000000000000000000000000000000..dde111492f623886bc3db8fa867ce8170a59604d
--- /dev/null
+++ b/lib/GEODE/Metadata/PrimaryKey.hs
@@ -0,0 +1,46 @@
+{-# 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" ]
diff --git a/lib/GEODE/Metadata/TSV.hs b/lib/GEODE/Metadata/TSV.hs
index cd06047c5cc9c44168fccac6cfd79fd7b030d3c2..e8e84d2c7fd59407ca396b6e0a225483c7afa089 100644
--- a/lib/GEODE/Metadata/TSV.hs
+++ b/lib/GEODE/Metadata/TSV.hs
@@ -1,7 +1,9 @@
-{-# 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
diff --git a/test/GEODE/Metadata/TestPrimaryKey.hs b/test/GEODE/Metadata/TestPrimaryKey.hs
new file mode 100644
index 0000000000000000000000000000000000000000..aa32db01300e10a47253c708395f8911bfe2b0b3
--- /dev/null
+++ b/test/GEODE/Metadata/TestPrimaryKey.hs
@@ -0,0 +1,26 @@
+{-# 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
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
index 0000000000000000000000000000000000000000..dcfad4e5c7b1f3be464ecc7fd768a4c9bd05ecd5
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,7 @@
+module Main (main) where
+
+import Test.HUnit (runTestTT, showCounts)
+import GEODE.Metadata.TestPrimaryKey (testPrimaryKey)
+
+main :: IO ()
+main = runTestTT testPrimaryKey >>= putStr . showCounts
diff --git a/test/Test/HUnit/Extra.hs b/test/Test/HUnit/Extra.hs
new file mode 100644
index 0000000000000000000000000000000000000000..046c3faf0b34ddb2b4d5ebd3d0b4d2ac1864b35a
--- /dev/null
+++ b/test/Test/HUnit/Extra.hs
@@ -0,0 +1,12 @@
+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