diff --git a/concrete-haskell.cabal b/concrete-haskell.cabal --- a/concrete-haskell.cabal +++ b/concrete-haskell.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: concrete-haskell -version: 0.1.0.9 +version: 0.1.0.10 synopsis: Library for the Concrete data format. description: Concrete is a Thrift-based data specification designed for Natural Language Processing (NLP) applications. This library provides a Haskell interface to code generated from the latest release of Concrete. It also has a number of utilities for converting various formats (JSON, CSV, XML, etc) to Concrete Communication objects. category: Data @@ -22,29 +22,29 @@ default-extensions: RecordWildCards build-depends: base >=4.6 && <5 - , bytestring - , bzlib - , containers - , directory - , filepath - , hashable - , megaparsec >=5.3.0 - , mtl + , bytestring ==0.10.8.1 + , bzlib ==0.5.0.5 + , containers ==0.5.7.1 + , directory ==1.3.0.0 + , filepath ==1.4.1.1 + , hashable ==1.2.6.1 + , megaparsec ==5.3.1 + , mtl ==2.2.1 , network ==2.6.3.2 , optparse-generic ==1.2.2 , path-io ==1.2.2 - , process - , QuickCheck - , scientific - , tar - , text + , process ==1.4.3.0 + , QuickCheck ==2.9.2 + , scientific ==0.3.5.1 + , tar ==0.5.0.3 + , text ==1.2.2.2 , thrift ==0.10.0 - , time - , unordered-containers - , uuid - , vector - , zip - , zlib + , time ==1.6.0.1 + , unordered-containers ==0.2.8.0 + , uuid ==1.3.13 + , vector ==0.10.12.2 + , zip ==0.1.11 + , zlib ==0.6.1.2 exposed-modules: Data.Concrete Data.Concrete.Services.ActiveLearnerClientService @@ -182,29 +182,29 @@ utils build-depends: base >=4.6 && <5 - , bytestring - , bzlib - , containers - , directory - , filepath - , hashable - , megaparsec >=5.3.0 - , mtl + , bytestring ==0.10.8.1 + , bzlib ==0.5.0.5 + , containers ==0.5.7.1 + , directory ==1.3.0.0 + , filepath ==1.4.1.1 + , hashable ==1.2.6.1 + , megaparsec ==5.3.1 + , mtl ==2.2.1 , network ==2.6.3.2 , optparse-generic ==1.2.2 , path-io ==1.2.2 - , process - , QuickCheck - , scientific - , tar - , text + , process ==1.4.3.0 + , QuickCheck ==2.9.2 + , scientific ==0.3.5.1 + , tar ==0.5.0.3 + , text ==1.2.2.2 , thrift ==0.10.0 - , time - , unordered-containers - , uuid - , vector - , zip - , zlib + , time ==1.6.0.1 + , unordered-containers ==0.2.8.0 + , uuid ==1.3.13 + , vector ==0.10.12.2 + , zip ==0.1.11 + , zlib ==0.6.1.2 , concrete-haskell other-modules: InspectCommunication @@ -217,29 +217,29 @@ default-extensions: RecordWildCards build-depends: base >=4.6 && <5 - , bytestring - , bzlib - , containers - , directory - , filepath - , hashable - , megaparsec >=5.3.0 - , mtl + , bytestring ==0.10.8.1 + , bzlib ==0.5.0.5 + , containers ==0.5.7.1 + , directory ==1.3.0.0 + , filepath ==1.4.1.1 + , hashable ==1.2.6.1 + , megaparsec ==5.3.1 + , mtl ==2.2.1 , network ==2.6.3.2 , optparse-generic ==1.2.2 , path-io ==1.2.2 - , process - , QuickCheck - , scientific - , tar - , text + , process ==1.4.3.0 + , QuickCheck ==2.9.2 + , scientific ==0.3.5.1 + , tar ==0.5.0.3 + , text ==1.2.2.2 , thrift ==0.10.0 - , time - , unordered-containers - , uuid - , vector - , zip - , zlib + , time ==1.6.0.1 + , unordered-containers ==0.2.8.0 + , uuid ==1.3.13 + , vector ==0.10.12.2 + , zip ==0.1.11 + , zlib ==0.6.1.2 , concrete-haskell other-modules: IngestCommunications @@ -250,28 +250,28 @@ main-is: tests/UnitTests.hs build-depends: base >=4.6 && <5 - , bytestring - , bzlib - , containers - , directory - , filepath - , hashable - , megaparsec >=5.3.0 - , mtl + , bytestring ==0.10.8.1 + , bzlib ==0.5.0.5 + , containers ==0.5.7.1 + , directory ==1.3.0.0 + , filepath ==1.4.1.1 + , hashable ==1.2.6.1 + , megaparsec ==5.3.1 + , mtl ==2.2.1 , network ==2.6.3.2 , optparse-generic ==1.2.2 , path-io ==1.2.2 - , process - , QuickCheck - , scientific - , tar - , text + , process ==1.4.3.0 + , QuickCheck ==2.9.2 + , scientific ==0.3.5.1 + , tar ==0.5.0.3 + , text ==1.2.2.2 , thrift ==0.10.0 - , time - , unordered-containers - , uuid - , vector - , zip - , zlib + , time ==1.6.0.1 + , unordered-containers ==0.2.8.0 + , uuid ==1.3.13 + , vector ==0.10.12.2 + , zip ==0.1.11 + , zlib ==0.6.1.2 , concrete-haskell default-language: Haskell2010 diff --git a/src/Data/Concrete/Parsers/JSON.hs b/src/Data/Concrete/Parsers/JSON.hs --- a/src/Data/Concrete/Parsers/JSON.hs +++ b/src/Data/Concrete/Parsers/JSON.hs @@ -25,6 +25,7 @@ , manyTill , anyChar , runParser + , try , some , char , choice @@ -99,11 +100,9 @@ arrayEntryP = pathArrayEntryRule $ do jsonP - return () -arrayP = pathArrayRule $ do - c <- brackets (arrayEntryP `sepBy` comma) - return () +arrayP = pathArrayRule $ do + (try (brackets space)) <|> ((brackets (arrayEntryP `sepBy` comma)) >> return ()) pairP = do key <- stringLiteral diff --git a/src/Data/Concrete/Parsers/Utils.hs b/src/Data/Concrete/Parsers/Utils.hs --- a/src/Data/Concrete/Parsers/Utils.hs +++ b/src/Data/Concrete/Parsers/Utils.hs @@ -28,15 +28,7 @@ import Data.Maybe (fromJust) import Text.Printf (printf) -substr :: T.Text -> Int -> Int -> String -substr t s e = T.unpack res - where - (_, start) = T.splitAt (fromIntegral s) t - res = T.take (fromIntegral $ e - s) start - -makeId :: [(Text, Text)] -> Text -> Int -> Text -makeId ss i n = foldr (\ (a, b) x -> T.replace (T.concat ["${", a, "}"]) b x) i (("", (pack . show) n):ss) - +-- | Wraps a rule that corresponds to a single Communication communicationRule :: (Communication -> Communication) -> CommunicationParser a -> CommunicationParser a communicationRule tr p = do offset <- (fromIntegral . stateTokensProcessed) <$> getParserState @@ -62,6 +54,18 @@ clearState return o +-- | Extracts a sub-string from a text object +substr :: T.Text -> Int -> Int -> String +substr t s e = T.unpack res + where + (_, start) = T.splitAt (fromIntegral s) t + res = T.take (fromIntegral $ e - s) start + +-- | Performs variable substitution on an ID string +makeId :: [(Text, Text)] -> Text -> Int -> Text +makeId ss i n = foldr (\ (a, b) x -> T.replace (T.concat ["${", a, "}"]) b x) i (("", (pack . show) n):ss) + +-- | Resets the "Communication-building" state inside the parser clearState :: CommunicationParser () clearState = do bs <- get @@ -72,61 +76,64 @@ put s return () ---pathArrayRule :: CommunicationParser a -> CommunicationParser a ---pathArrayRule p = p - +-- | Wraps a rule corresponding to an array-like object, pushing a dummy +-- numeric component onto the path at the start, and popping at the end pathArrayRule :: CommunicationParser a -> CommunicationParser a pathArrayRule p = do pushPathComponent (show (-1)) - r <- p + (m, r) <- match p popPathComponent return r --- pathArrayEntryRule :: CommunicationParser a -> CommunicationParser a --- pathArrayEntryRule p = p - +-- | Wraps a rule corresponding to an array-like entry, incrementing the +-- top-level path component pathArrayEntryRule :: CommunicationParser a -> CommunicationParser a pathArrayEntryRule p = do incrementPathComponent p +-- | Wraps a rule corresponding to a dictionary-like object, pushing a +-- dummy string component onto the path, and popping at the end pathDictionaryRule :: CommunicationParser a -> CommunicationParser a pathDictionaryRule p = do pushPathComponent "PLACEHOLDER" (m, r) <- match p - t' <- popPathComponent + popPathComponent return r +-- | Wraps a rule corresponding to a key in a dictionary-like object, modifying +-- the current head of the stack pathDictionaryKeyRule :: CommunicationParser String -> CommunicationParser String pathDictionaryKeyRule p = do t' <- p modifyPathComponent (\x -> t') return "" +-- | Push a string component onto the path pushPathComponent :: String -> CommunicationParser () pushPathComponent s = do Bookkeeper{..} <- get - --liftIO $ print ("starting component") -- , s, path) modify (\ bs -> bs { path=s:path }) return () +-- | Pop the top-level component from the path popPathComponent :: CommunicationParser String popPathComponent = do Bookkeeper{..} <- get let (p:ps) = path - --liftIO $ print ("ending component", p) --, ps) modify (\ bs -> bs { path=ps }) return p +-- | Modify the top-level path component modifyPathComponent :: (String -> String) -> CommunicationParser () modifyPathComponent f = do Bookkeeper{..} <- get let (p:ps) = path p' = f p - --liftIO $ print ("modifying component", p, "to", p') -- , ps) modify (\ bs -> bs { path=p':ps }) return () +-- | Increment the top-level path component as an integer incrementPathComponent :: CommunicationParser Int incrementPathComponent = do Bookkeeper{..} <- get @@ -135,6 +142,7 @@ modify (\ bs -> bs { path=(show p'):(tail path) }) return p' +-- | Wraps a rule corresponding to a Communication Section sectionRule :: (Section -> Section) -> CommunicationParser a -> CommunicationParser a sectionRule t p = do s <- (fromIntegral . stateTokensProcessed) <$> getParserState @@ -151,7 +159,8 @@ else put $ bs { communication=communication { communication_sectionList=(cons section) <$> (communication_sectionList communication) } } return v - + +-- | A data structure that is positioned inside a document and whose boundaries can be adjusted class Located a where getTextSpan :: a -> TextSpan setTextSpan :: TextSpan -> a -> a diff --git a/src/Data/Concrete/Utils.hs b/src/Data/Concrete/Utils.hs --- a/src/Data/Concrete/Utils.hs +++ b/src/Data/Concrete/Utils.hs @@ -190,9 +190,10 @@ res = T.take (fromIntegral $ e - s) start showCommunication :: Communication -> T.Text -showCommunication c = T.concat [C.communication_id c, " ", C.communication_type c, "\n", " Content:", "\n", T.intercalate "\n" sects, "\n"] +showCommunication c = T.concat [C.communication_id c, " ", C.communication_type c, "\n Content sections:", "\n", T.intercalate "\n" contentSects, "\n Metadata sections: ", metadataText, "\n"] where ss = L.concat $ L.map V.toList (maybeToList (C.communication_sectionList c)) t = (fromJust . C.communication_text) c - sects = L.map (showSection t) ((L.filter (\x -> section_kind x == "content")) ss) - + contentSects = L.map (showSection t) ((L.filter (\x -> section_kind x == "content")) ss) + metadataSects = L.map (fromMaybe "?" . C.section_label) ((L.filter (\x -> section_kind x /= "content")) ss) + metadataText = T.intercalate ", " metadataSects diff --git a/utils/IngestCommunications.hs b/utils/IngestCommunications.hs --- a/utils/IngestCommunications.hs +++ b/utils/IngestCommunications.hs @@ -60,5 +60,6 @@ return $ StoreService.store con (Nothing, Nothing, Nothing) -> return $ writeCommunication stdout _ -> error "Specify either an output file, a host and port, or nothing (for stdout)" - cs <- ingest cb cp (decodeUtf8 ih) (contentSectionTypes ps) (commId ps) (commType ps) + cs <- ingest (putStrLn . unpack . CU.showCommunication) cp (decodeUtf8 ih) (contentSectionTypes ps) (commId ps) (commType ps) + --cs <- ingest print cp (decodeUtf8 ih) (contentSectionTypes ps) (commId ps) (commType ps) return ()