diff --git a/geode.cabal b/geode.cabal index f88f1e36f1b2c088ad78e2271adf57a784cb5c72..ae999fca87c32e9d2fd0f23e12af88c7ea914263 100644 --- a/geode.cabal +++ b/geode.cabal @@ -22,11 +22,11 @@ extra-source-files: CHANGELOG.md library exposed-modules: GEODE.Metadata + , GEODE.Metadata.Entry , GEODE.Options -- Modules included in this library but not exported. - other-modules: GEODE.Metadata.Entry - , GEODE.Metadata.PrimaryKey + other-modules: GEODE.Metadata.PrimaryKey , GEODE.Metadata.Projector , GEODE.Metadata.TSV , GEODE.Metadata.Types @@ -38,7 +38,8 @@ library , 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 + , mtl >= 2.2.2 && <2.3 + , 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 @@ -50,11 +51,15 @@ test-suite ghc-geode-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs - other-modules: GEODE.Metadata.TestPrimaryKey + other-modules: GEODE.Metadata.TestEntry + , GEODE.Metadata.TestPrimaryKey , Test.HUnit.Extra build-depends: base , bytestring + , containers , cassava , geode + , mtl , HUnit >= 1.6.2.0 && <1.7 + , text , unordered-containers diff --git a/lib/GEODE/Metadata.hs b/lib/GEODE/Metadata.hs index 9eaeab858926f8ae9c6f14fc2798a9e5256a209a..99027885fff42f948ca834f5fb9d1220cf573ce7 100644 --- a/lib/GEODE/Metadata.hs +++ b/lib/GEODE/Metadata.hs @@ -16,6 +16,7 @@ import Data.Map.Strict as Map (Map, alter, empty, insert, toList) import Data.Text as Text (Text, intercalate, unpack) import GEODE.Metadata.PrimaryKey as PrimaryKey import GEODE.Metadata.Entry as Entry + ( Entry(headWord, name, page), entry, normalize ) import GEODE.Metadata.Projector as Projector import GEODE.Metadata.TSV as TSV import GEODE.Metadata.Types as Types diff --git a/lib/GEODE/Metadata/Entry.hs b/lib/GEODE/Metadata/Entry.hs index d34326eaaa433d931f9eab2fe568c8cbcb053eed..3ca2186d527c3a552355a17f9705eb3f0b1f4367 100644 --- a/lib/GEODE/Metadata/Entry.hs +++ b/lib/GEODE/Metadata/Entry.hs @@ -1,10 +1,15 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, FlexibleContexts, NamedFieldPuns, OverloadedStrings #-} module GEODE.Metadata.Entry ( Entry(..) - , headerSection ) where + , HeadWords + , entry + , normalize ) where +import Control.Monad.State (MonadState(..)) +import Data.Char (isAlphaNum, isSpace, isUpper, toLower) import Data.Csv (FromNamedRecord(..), ToNamedRecord(..)) -import Data.Text (Text) +import Data.Map as Map (Map, insertLookupWithKey) +import Data.Text as Text (Text, concat, foldl', pack, snoc) import GEODE.Metadata.TSV (Default(..), DefaultHeader(..)) import GHC.Generics (Generic) @@ -18,3 +23,22 @@ instance ToNamedRecord Entry instance DefaultHeader Entry where headerSection = Default [ "headWord", "name", "page" ] + +normalize :: Text -> Text +normalize = Text.foldl' appendIf mempty + where + appendIf tmpText newChar + | isSpace newChar = tmpText + | isUpper newChar = tmpText `snoc` toLower newChar + | isAlphaNum newChar = tmpText `snoc` newChar + | otherwise = tmpText `snoc` '-' + +type HeadWords = Map Text Int + +entry :: MonadState HeadWords m => Text -> Int -> m Entry +entry headWord page = do + count <- maybe "0" (Text.pack . show) <$> state nextId + pure $ Entry { headWord, name = Text.concat [prefix, "-", count], page } + where + nextId = insertLookupWithKey (\_ _ n -> n+1) prefix 1 + prefix = normalize headWord diff --git a/test/GEODE/Metadata/TestEntry.hs b/test/GEODE/Metadata/TestEntry.hs new file mode 100644 index 0000000000000000000000000000000000000000..3faadd7616f9e3ef242f06044cbdb86648cb8d91 --- /dev/null +++ b/test/GEODE/Metadata/TestEntry.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +module GEODE.Metadata.TestEntry (testEntry) where + +import Control.Monad.State (evalState) +import Data.ByteString.Char8 as BS (pack) +import Data.Csv (ToNamedRecord(..)) +import Data.HashMap.Strict ((!?)) +import Data.Map as Map (empty) +import Data.Text (dropEnd) +import GEODE.Metadata (Default(..), DefaultHeader(..), entry, normalize) +import GEODE.Metadata.Entry (Entry(..)) +import Test.HUnit (Test(..), (~?=)) +import Test.HUnit.Extra (isJust) + +testEntry :: Test +testEntry = TestLabel "Testing the Entry data type" $ + TestList [ testToNamedRecord, testNormalize, testEntryConstructor ] + +testToNamedRecord :: Test +testToNamedRecord = TestLabel "Testing ToNamedRecord instance" $ + TestList [ has3Keys, validDefaultHeader ] + where + has3Keys = length aNamedRecord ~?= 3 + validDefaultHeader = + TestList ((isJust . (aNamedRecord !?) . BS.pack) <$> defaultHeader) + aNamedRecord = toNamedRecord anEntry + Default defaultHeader = (headerSection :: Default Entry) + +testNormalize :: Test +testNormalize = TestLabel "Testing function normalize" . TestList $ + check <$> [ ("", "") + , ("é", "é") + , (headWord anEntry, dropEnd 2 $ name anEntry) ] + where + check (a, b) = normalize a ~?= b + +testEntryConstructor :: Test +testEntryConstructor = TestLabel "Testing the entry constructor" . TestList $ + [ a0 ~?= "a-0" + , a1 ~?= "a-1" + , b0 ~?= "b-0" ] + where + (a0, a1, b0) = flip evalState Map.empty $ (,,) + <$> (name <$> entry "A" 1) + <*> (name <$> entry "A" 1) + <*> (name <$> entry "B" 2) + +anEntry :: Entry +anEntry = Entry "ALCALA DE HÉNARÈS" "alcaladehénarès-0" 1212 diff --git a/test/Main.hs b/test/Main.hs index dcfad4e5c7b1f3be464ecc7fd768a4c9bd05ecd5..38a4f8a4a9194b2b9d3883d905cbd10b5cbdc377 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,18 @@ module Main (main) where -import Test.HUnit (runTestTT, showCounts) +import Test.HUnit (Counts(..), Test(..), runTestTT, showCounts) import GEODE.Metadata.TestPrimaryKey (testPrimaryKey) +import GEODE.Metadata.TestEntry (testEntry) +import System.Exit (exitFailure, exitSuccess) + +testMetadata :: Test +testMetadata = TestLabel "Metadata suite" $ + TestList [ testPrimaryKey, testEntry ] main :: IO () -main = runTestTT testPrimaryKey >>= putStr . showCounts +main = do + result <- runTestTT testMetadata + putStr $ showCounts result + if (errors result == 0) && (failures result == 0) + then exitSuccess + else exitFailure