concrete-haskell 0.1.0.6 → 0.1.0.7
raw patch · 11 files changed
+599/−313 lines, 11 filesdep +attoparsecdep +scientificdep ~megaparsecnew-component:exe:ingest_communications
Dependencies added: attoparsec, scientific
Dependency ranges changed: megaparsec
Files
- concrete-haskell.cabal +20/−22
- src/Data/Concrete/Parsers.hs +58/−0
- src/Data/Concrete/Parsers/CONLL.hs +106/−0
- src/Data/Concrete/Parsers/JSON.hs +105/−0
- src/Data/Concrete/Parsers/Types.hs +32/−0
- src/Data/Concrete/Parsers/Utils.hs +86/−0
- src/Data/Concrete/Types.hs +33/−0
- src/Data/Concrete/Utils.hs +61/−14
- utils/IngestCommunications.hs +97/−0
- utils/IngestJson.hs +0/−256
- utils/InspectCommunication.hs +1/−21
concrete-haskell.cabal view
@@ -1,5 +1,5 @@ name: concrete-haskell-version: 0.1.0.6+version: 0.1.0.7 synopsis: Library for the Concrete data format. description: Library for the Concrete data format. homepage: https://github.com/hltcoe@@ -7,14 +7,21 @@ license-file: LICENSE author: Thomas Lippincott maintainer: tom@cs.jhu.edu-copyright: 2016+copyright: 2017 category: Data build-type: Simple cabal-version: >=1.10-+ library hs-source-dirs: src- exposed-modules: Data.Concrete, Data.Concrete.Utils+ exposed-modules: Data.Concrete+ , Data.Concrete.Types+ , Data.Concrete.Utils+ , Data.Concrete.Parsers + , Data.Concrete.Parsers.Types+ , Data.Concrete.Parsers.Utils + , Data.Concrete.Parsers.JSON+ , Data.Concrete.Parsers.CONLL other-modules: Communication_Types , Access_Types , Annotate_Types@@ -54,11 +61,6 @@ , StoreCommunicationService , StoreCommunicationService_Client , StoreCommunicationService_Iface---- ResultsServer, ActiveLearnerClient, ActiveLearnerServer, Feedback, Summarization, SearchProxy- - - build-depends: base >= 4.6 && < 5 , thrift == 0.10.0 , text@@ -74,16 +76,18 @@ , time , filepath , process- , directory + , directory+ , attoparsec+ , megaparsec >= 5.3.0+ , scientific+ , mtl default-language: Haskell2010- default-extensions: DuplicateRecordFields- ghc-options: -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10+ default-extensions: DuplicateRecordFields, RecordWildCards -executable ingest_json- main-is: IngestJson.hs+executable ingest_communications+ main-is: IngestCommunications.hs hs-source-dirs: utils build-depends: base >= 4.6 && < 5- , megaparsec , bytestring , text , concrete-haskell@@ -93,18 +97,14 @@ , process , directory , vector- , mtl- , zlib + , zlib default-language: Haskell2010 default-extensions: DuplicateRecordFields- ghc-options: -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10 - executable inspect_communications main-is: InspectCommunication.hs hs-source-dirs: utils build-depends: base >= 4.6 && < 5- , megaparsec , bytestring , text , concrete-haskell@@ -114,8 +114,6 @@ , process , directory , vector- , mtl , zlib default-language: Haskell2010 default-extensions: DuplicateRecordFields- ghc-options: -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10
+ src/Data/Concrete/Parsers.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+{-|+This module is designed to enable converting arbitrary formats+described as simple context-free (or even context-sensitive)+grammars into Concrete Communication objects.++UUIDs are generated when the Communications are serialized,+and so the module avoids the need for any impure computations+until that point.+-}+module Data.Concrete.Parsers+ ( communicationParsers+ , ingest+ ) where++import qualified Data.Map as Map+import Data.Vector (fromList, Vector)+import Data.Map (Map)+import Data.Concrete.Utils (createAnnotationMetadata, getUUID, writeCommunication)+import Data.Concrete ( default_Communication+ , Communication(..)+ , default_Section+ , Section(..)+ , default_AnnotationMetadata+ , AnnotationMetadata(..)+ , default_CommunicationMetadata+ , CommunicationMetadata(..)+ , default_Sentence+ , Sentence(..)+ , default_TextSpan+ , TextSpan(..)+ )+import System.IO (stdin, stdout, stderr, openFile, Handle, IOMode(..), hPutStrLn)+import Control.Monad.State (runStateT)+import Data.ByteString.Lazy (ByteString)+import Data.Text.Lazy (Text, pack)+import qualified Data.Concrete.Parsers.JSON as JSON+import qualified Data.Concrete.Parsers.CONLL as CONLL+import Data.Concrete.Types+import Data.Concrete.Parsers.Types+import Control.Monad.IO.Class (liftIO)+import Text.Megaparsec (runParserT', initialPos, State(..), unsafePos)+import qualified Data.List.NonEmpty as NE+import Data.Vector (Vector, fromList, snoc, empty)++communicationParsers = Map.fromList [ ("JSON", ("JSON array of arbitrary objects", JSON.arrayOfObjectsP))+ , ("CONLL", ("CONLL format", CONLL.arrayOfObjectsP))+ ]++ingest :: CommunicationAction -> CommunicationParser a -> Text -> [String] -> String -> String -> IO ()+ingest a p t cs i ct= do+ let s = State { stateInput=t+ , statePos=NE.fromList $ [initialPos "JSON"]+ , stateTokensProcessed=0+ , stateTabWidth=unsafePos 8+ }+ runStateT (runParserT' p s) (Bookkeeper (default_Communication { communication_sectionList=Just empty }) Map.empty [] [] a cs (pack i) ct)+ return ()
+ src/Data/Concrete/Parsers/CONLL.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings, ApplicativeDo #-}+module Data.Concrete.Parsers.CONLL+ ( arrayOfObjectsP+ ) where++import Data.List (intercalate)+import Data.Concrete.Parsers.Types (Bookkeeper(..), CommunicationParser)+import Data.Concrete.Parsers.Utils (communicationRule)+import Data.Scientific (scientific, Scientific(..))+import Data.Text.Lazy (pack, Text)+import Data.Functor (($>))+import qualified Data.Map as Map+import Data.Map (Map)+import Data.List.NonEmpty (fromList)+import Text.Megaparsec.Lexer (symbol, lexeme, signed, number)+import Text.Megaparsec.Pos (initialPos, defaultTabWidth)+import Text.Megaparsec.Error (Dec)+import Text.Megaparsec ( parseErrorPretty+ , (<|>)+ , space+ , hexDigitChar+ , count+ , manyTill+ , anyChar+ , runParser+ , some+ , char+ , choice+ , sepBy+ , between+ , match+ , ParsecT+ , runParserT'+ , State(..)+ , getParserState+ )++import Text.Megaparsec.Text.Lazy (Parser)+import Data.Concrete (default_Communication, Communication(..))+import qualified Control.Monad.State as S+import qualified Control.Monad.Identity as I+import Data.Concrete.Types+import Data.Concrete.Parsers.Utils (communicationRule, sectionRule)+ +arrayOfObjectsP :: ParsecT Dec Text (S.StateT Bookkeeper IO) ()+arrayOfObjectsP = brackets ((communicationRule id objectP) `sepBy` comma) >> return ()++jsonP = sectionRule id jsonP'++jsonP' = lexeme' $ choice [nullP, numberP, stringP, boolP, objectP, arrayP]+ +nullP = symbol' "null" >> return ()+ +boolP = (symbol' "true" <|> symbol' "false") >> return ()+ +numberP = signed space number >> return ()++stringP = pack <$> stringLiteral >> return ()++objectP = Map.fromList <$> braces (pairP `sepBy` comma) >> return ()++arrayEntryP = do+ bs@(Bookkeeper{..}) <- S.get+ let p = (read $ head path) :: Int+ S.put $ bs { path=(show (p + 1)):(tail path) } + jsonP+ return ()+ +escapedChar = do+ char '\\'+ choice [ char '\"' $> '\"'+ , char '\\' $> '\\'+ , char '/' $> '/'+ , char 'n' $> '\n'+ , char 'r' $> '\r'+ , char 'f' $> '\f'+ , char 't' $> '\t'+ , char 'b' $> '\b'+ , unicodeEscape+ ]++unicodeEscape = char 'u' >> count 4 hexDigitChar >>= (\code -> return $ toEnum (read ("0x" ++ code)))++stringLiteral = lexeme' $ do + char '\"'+ (escapedChar <|> anyChar) `manyTill` char '\"'++arrayP = do+ S.modify' (\ bs@(Bookkeeper{..}) -> bs { path=(show (-1)):path })+ c <- brackets (arrayEntryP `sepBy` comma)+ S.modify' (\ bs@(Bookkeeper{..}) -> bs { path=tail path})+ return ()++pairP = do+ key <- stringLiteral+ S.modify' (\ bs@(Bookkeeper{..}) -> bs { path=key:path })+ symbol' ":"+ value <- jsonP+ S.modify' (\ bs@(Bookkeeper{..}) -> bs { path=tail path})+ return (key, value)++lexeme' = lexeme space+symbol' = symbol space+brackets = between (symbol' "[") (symbol' "]")+braces = between (symbol' "{") (symbol' "}")+comma = symbol' ","
+ src/Data/Concrete/Parsers/JSON.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+module Data.Concrete.Parsers.JSON+ ( arrayOfObjectsP+ ) where++import Data.Maybe (fromJust)+import Data.List (intercalate)+import Data.Concrete.Parsers.Types (Bookkeeper(..), CommunicationParser)+import Data.Concrete.Parsers.Utils (communicationRule, Located(..))+import Data.Scientific (scientific, Scientific(..))+import Data.Text.Lazy (pack, Text)+import Data.Functor (($>))+import qualified Data.Map as Map+import Data.Map (Map)+import Data.List.NonEmpty (fromList)+import Text.Megaparsec.Lexer (symbol, lexeme, signed, number)+import Text.Megaparsec.Pos (initialPos, defaultTabWidth)+import Text.Megaparsec.Error (Dec)+import Text.Megaparsec ( parseErrorPretty+ , (<|>)+ , space+ , hexDigitChar+ , count+ , manyTill+ , anyChar+ , runParser+ , some+ , char+ , choice+ , sepBy+ , between+ , match+ , ParsecT+ , runParserT'+ , State(..)+ , getParserState+ )++import Text.Megaparsec.Text.Lazy (Parser)+import Data.Concrete (default_Communication, Communication(..), Section(..), TextSpan(..))+import qualified Control.Monad.State as S+import qualified Control.Monad.Identity as I+import Data.Concrete.Types+import Data.Concrete.Parsers.Utils (communicationRule, sectionRule)++arrayOfObjectsP :: CommunicationParser ()+arrayOfObjectsP = brackets ((communicationRule id objectP) `sepBy` comma) >> return ()++jsonP = lexeme' $ choice [nullP, numberP, stringP, boolP, objectP, arrayP]+ +nullP = sectionRule id $ symbol' "null" >> return ()+ +boolP = sectionRule id $ (symbol' "true" <|> symbol' "false") >> return ()+ +numberP = sectionRule id $ signed space number >> return ()++stringP = sectionRule (adjustTextSpan 1 (-1)) $ pack <$> stringLiteral >> return ()++escapedChar = do+ char '\\'+ choice [ char '\"' $> '\"'+ , char '\\' $> '\\'+ , char '/' $> '/'+ , char 'n' $> '\n'+ , char 'r' $> '\r'+ , char 'f' $> '\f'+ , char 't' $> '\t'+ , char 'b' $> '\b'+ , unicodeEscape+ ]++unicodeEscape = char 'u' >> count 4 hexDigitChar >>= (\code -> return $ toEnum (read ("0x" ++ code)))++stringLiteral = lexeme' $ do + char '\"'+ (escapedChar <|> anyChar) `manyTill` char '\"'++arrayEntryP = do+ bs@(Bookkeeper{..}) <- S.get+ let p = (read $ head path) :: Int+ S.modify' (\ bs -> bs { path=(show (p + 1)):(tail path) } )+ jsonP+ return ()++arrayP = do+ S.modify' (\ bs@(Bookkeeper{..}) -> bs { path=(show (-1)):path })+ c <- brackets (arrayEntryP `sepBy` comma)+ S.modify' (\ bs@(Bookkeeper{..}) -> bs { path=tail path})+ return ()++pairP = do+ key <- stringLiteral+ S.modify' (\ bs@(Bookkeeper{..}) -> bs { path=key:path })+ symbol' ":"+ value <- jsonP+ S.modify' (\ bs@(Bookkeeper{..}) -> bs { path=tail path})+ return (key, value)++objectP = sectionRule id $ Map.fromList <$> braces (pairP `sepBy` comma) >> return ()++lexeme' = lexeme space+symbol' = symbol space+brackets = between (symbol' "[") (symbol' "]")+braces = between (symbol' "{") (symbol' "}")+comma = symbol' ","
+ src/Data/Concrete/Parsers/Types.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+module Data.Concrete.Parsers.Types ( Bookkeeper(..)+ , CommunicationParser+ , CommunicationAction+ ) where++import Data.Text.Lazy (Text)+import Data.Concrete (Communication, Section)+import Text.Megaparsec (ParsecT)+import Text.Megaparsec.Error (Dec)+import Data.Map (Map)+import Control.Monad.State (StateT)++-- | A 'CommunicationAction' gets called on each Communication+-- as parsing proceeds+type CommunicationAction = Communication -> IO ()+ +-- | A 'Bookkeeper' tracks information about an ongoing attempt+-- to parse a Text stream into Communication objects.+data Bookkeeper = Bookkeeper { communication :: Communication+ , valueMap :: Map String String -- | An arbitrary string-to-string map+ , path :: [String]+ , sections :: [Section] -- | List of Sections accumulated for the Communication currently being parsed+ , action :: CommunicationAction+ , contentSections :: [String]+ , commId :: Text+ , commType :: String+ }++-- | A 'CommunicationParser' is a stateful Megaparsec parser that, as it+-- processes a Text stream, builds a list of Concrete Communications.+type CommunicationParser a = ParsecT Dec Text (StateT Bookkeeper IO) a
+ src/Data/Concrete/Parsers/Utils.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+module Data.Concrete.Parsers.Utils ( communicationRule+ , sectionRule+ , Located(..)+ ) where++import Data.Text.Lazy (Text, pack, unpack, replace)+import qualified Data.Text.Lazy as T+import Data.List (intercalate)+import Data.Concrete.Parsers.Types (Bookkeeper(..), CommunicationParser, CommunicationAction)+import Text.Megaparsec (ParsecT, getParserState, stateTokensProcessed, match)+import Text.Megaparsec.Error (Dec)+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Monad.State (State, get, put)+import Data.Concrete (default_Communication, Communication(..), default_Section, Section(..), default_TextSpan, TextSpan(..))+import Data.Concrete.Utils (getUUID, createAnnotationMetadata)+import Control.Monad.IO.Class (liftIO)+import Data.Vector (Vector, fromList, snoc, empty, cons, toList)+import Data.Maybe (fromJust)++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 -> Text+makeId ss i = foldr (\ (a, b) x -> T.replace (T.concat ["${", a, "}"]) b x) i ss++communicationRule :: (Communication -> Communication) -> CommunicationParser a -> CommunicationParser a+communicationRule tr p = do+ offset <- (fromIntegral . stateTokensProcessed) <$> getParserState + (t, o) <- match p+ bs@(Bookkeeper {..}) <- get+ let sections = (toList . fromJust) (communication_sectionList communication)+ (u:us) <- liftIO $ sequence (replicate (length sections + 1) getUUID)+ m <- liftIO $ createAnnotationMetadata "concrete-haskell ingester"+ let sections' = [s { section_uuid=u'+ , section_kind=if elem ((unpack . fromJust) section_label) contentSections then "content" else "metadata"+ , section_textSpan=(\ (Just (TextSpan{..})) -> Just $ TextSpan (textSpan_start - offset) (textSpan_ending - offset)) section_textSpan+ } | (u', s@(Section{..})) <- zip us sections]++ sectionVals = [(fromJust section_label, pack $ substr (pack t) ((fromIntegral . textSpan_start . fromJust) section_textSpan) ((fromIntegral . textSpan_ending . fromJust) section_textSpan)) | Section{..} <- sections']+ c = communication { communication_metadata=m+ , communication_text=Just $ pack t+ , communication_uuid=u+ , communication_id=makeId sectionVals commId+ , communication_sectionList=Just $ fromList sections'+ }+ put $ bs { communication=default_Communication { communication_sectionList=Just empty }, valueMap=Map.fromList [], sections=[] }+ liftIO $ action (tr c)+ return o++sectionRule :: (Section -> Section) -> CommunicationParser a -> CommunicationParser a+sectionRule t p = do+ s <- (fromIntegral . stateTokensProcessed) <$> getParserState+ v <- p+ e <- (fromIntegral . stateTokensProcessed) <$> getParserState+ bs@(Bookkeeper {..}) <- get+ let path' = (intercalate "." (reverse path))+ section = t $ default_Section { section_label=(Just . pack) path'+ , section_textSpan=Just $ TextSpan s e+ }+ if length path == 0+ then+ return ()+ else+ put $ bs { communication=communication { communication_sectionList=(cons section) <$> (communication_sectionList communication) } }+ return v++class Located a where+ getTextSpan :: a -> TextSpan+ setTextSpan :: TextSpan -> a -> a+ adjustTextSpan :: Integral i => i -> i -> a -> a+ adjustTextSpan s' e' a = setTextSpan (ts { textSpan_start=textSpan_start + (fromIntegral s')+ , textSpan_ending=textSpan_ending + (fromIntegral e')+ }) a+ where+ ts@(TextSpan {..}) = getTextSpan a++instance Located Section where+ getTextSpan s = (fromJust . section_textSpan) s+ setTextSpan ts s = s { section_textSpan=Just ts }+
+ src/Data/Concrete/Types.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+module Data.Concrete.Types+ ( --ProtoSection(..)+ --, ProtoCommunication+ ) where++import Data.Text.Lazy (Text)+import Data.Concrete (Communication)+++-- data ProtoSection = ProtoSection { start :: Int+-- , end :: Int+-- , label :: String+-- , kind :: String+-- }+ +-- type ProtoCommunication = (Text, [ProtoSection])++-- type CommunicationStorer = [Communication] -> IO ()++-- -- | A 'Bookkeeper' tracks information about an ongoing attempt+-- -- to parse a Text stream into Communication objects.+-- data Bookkeeper = Bookkeeper { valueMap :: Map String String -- | An arbitrary string-to-string map+-- , comms :: [Communication] -- | List of Communications that have been parsed so far+-- , sections :: [Section] -- | List of Sections accumulated for the Communication currently being parsed+-- }++-- -- | A 'CommunicationParser' is a stateful Megaparsec parser that, as it+-- -- processes a Text stream, builds a list of Concrete Communications.+-- type CommunicationParser a = ParsecT Dec Text (State Bookkeeper) a+++-- --type CommParser ParsecT Dec Text (S.State Bookkeeping) ()
src/Data/Concrete/Utils.hs view
@@ -4,13 +4,16 @@ getUUID , createAnnotationMetadata , readCommunications- , writeCommunications + , writeCommunications+ , writeCommunication+ , showCommunication ) where import GHC.Generics import qualified Data.Concrete as C-import Data.Concrete (Communication(..), UUID(..), default_Communication)+import Data.Concrete (Communication(..), UUID(..), default_Communication, read_Communication) import Data.Text+import Data.Maybe (fromJust, maybeToList) import Data.ByteString.Lazy import Data.Map import Data.UUID.V4 (nextRandom)@@ -35,27 +38,43 @@ import Data.Either (rights) import Control.Monad (liftM) import Data.Foldable (foldr)+import System.IO (Handle)+import qualified Data.Vector as V getUUID :: IO UUID getUUID = do uuid <- (T.pack . toString) <$> nextRandom return $ UUID uuid -writeCommunications :: String -> [Communication] -> IO ()+writeCommunications :: Handle -> [Communication] -> IO () writeCommunications out cs = do- let tarPath = (dropTarSuffix . takeFileName) out+ let tarPath = "comms" texts <- sequence [commToString c | c <- cs] let names = rights [Tar.toTarPath False (tarPath </> ((T.unpack . C.communication_id) c) <.> "comm") | c <- cs] entries = [Tar.fileEntry n t|(n, t) <- L.zip names texts] t = Tar.write entries- (BS.writeFile out . GZip.compress) t+ (BS.hPutStr out . GZip.compress) t +writeCommunication :: Handle -> Communication -> IO ()+writeCommunication out c = do+ t <- commToString c+ (BS.hPutStr out . GZip.compress) t+ readCommunications :: String -> IO [Communication] readCommunications f = do t <- (liftM GZip.decompress . BS.readFile) f- let es = Tar.read t- Right cs = Tar.foldlEntries (\x y -> ((stringToComm . entryToString . Tar.entryContent) y):x) ([] :: [IO Communication]) es- sequence cs+ transport <- newTString+ fillBuf (getRead transport) t+ let iproto = CompactProtocol transport+ readCommunication' iproto []+ where+ readCommunication' pr cs = do+ o <- tIsOpen $ getTransport pr + case o of+ True -> do+ c <- read_Communication pr+ readCommunication' pr $ c:cs+ False -> return cs entryToString :: Tar.EntryContent -> BS.ByteString entryToString (Tar.NormalFile s _) = s@@ -65,18 +84,26 @@ getWrite :: TString -> WriteBuffer getWrite (TString r w) = w +getRead :: TString -> ReadBuffer+getRead (TString r w) = r + newTString = do w <- newWriteBuffer r <- newReadBuffer return $ TString r w instance Transport TString where- tIsOpen = const $ return False- tClose = const $ return ()- tRead (TString r w) i = readBuf r i --return ""- tPeek (TString r w) = peekBuf r --const $ return Nothing- tWrite (TString r w) bs = writeBuf w bs --return ()- tFlush (TString r w) = flushBuf w >> return () --const$ return ()+ tIsOpen (TString r w) = do+ p <- peekBuf r+ case p of+ Nothing -> return False+ _ -> return True+ tClose (TString r w) = case peekBuf r of+ _ -> return ()+ tRead (TString r w) i = readBuf r i+ tPeek (TString r w) = peekBuf r+ tWrite (TString r w) bs = writeBuf w bs+ tFlush (TString r w) = flushBuf w >> return () commToString :: Communication -> IO BS.ByteString commToString c = do@@ -103,3 +130,23 @@ return C.default_AnnotationMetadata { C.annotationMetadata_tool=T.pack s , C.annotationMetadata_timestamp=time }++showSection :: T.Text -> C.Section -> T.Text+showSection t s = T.concat ["\t", ((fromJust . C.section_label) s), " ", (C.section_kind s), "--->", t']+ where+ C.TextSpan s' e' = (fromJust . C.section_textSpan) s+ t' = substr t (fromIntegral s') (fromIntegral e')++substr :: T.Text -> Int -> Int -> T.Text+substr t s e = res+ where+ (_, start) = T.splitAt (fromIntegral s) t + res = T.take (fromIntegral $ e - s) start++showCommunication :: Communication -> T.Text+showCommunication c = T.concat [C.communication_id c, " ", C.communication_type c, "\n", T.intercalate "\n" sects, "\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) ss+
+ utils/IngestCommunications.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BS+import Data.Map (toList, (!))+import Data.Monoid ((<>))+import Control.Monad (void, join, liftM)+import Data.Text.Lazy (Text, unpack, take)+import Data.Text.Lazy.Encoding (decodeUtf8)+import System.IO (stdin, stdout, stderr, openFile, Handle, IOMode(..), hPutStrLn)+import System.FilePath (takeExtension)+import qualified Codec.Compression.GZip as GZip+import Data.Concrete.Utils (writeCommunication)+import Data.Concrete.Parsers.Types (CommunicationParser)+import Data.Concrete.Parsers (communicationParsers, ingest)+import Options.Applicative ( Parser(..)+ , option+ , auto+ , short+ , long+ , metavar+ , strOption+ , help+ , execParser+ , info+ , helper+ , fullDesc+ , progDesc+ , many+ , switch+ , optional+ )++data Parameters = Parameters { inputFile :: Maybe String+ , outputFile :: Maybe String+ , commType :: String+ , commId :: String+ , contentSectionTypes :: [String]+ , format :: String+ } deriving (Show)++parameters :: Parser Parameters+parameters = Parameters+ <$> (optional $ strOption (short 'i'+ <> long "input"+ <> metavar "INPUT_FILE"+ <> help "Text file of JSON objects"+ )+ )+ <*> (optional $ strOption (short 'o'+ <> long "output"+ <> metavar "OUTPUT_FILE"+ <> help "Tar archive of Concrete Communications"+ )+ )+ <*> strOption (short 't'+ <> long "commType"+ <> metavar "COMMUNICATION_TYPE"+ <> help "String describing the type of Communication(s)"+ )+ <*> strOption (short 'I'+ <> long "commId"+ <> metavar "COMMUNICATION_ID"+ <> help "String describing the Communication ID"+ )+ <*> many (strOption (short 's'+ <> long "contentSectionTypes"+ <> metavar "CONTENT_SECTION_TYPES"+ <> help "The names of sections to be considered \"content\" rather than \"metadata\""+ ))+ <*> strOption (short 'f'+ <> long "format"+ <> help "Input format"+ )+ +main = do+ ps <- execParser opts+ ofd <- case outputFile ps of+ Just f -> openFile f WriteMode+ Nothing -> return stdout+ ih <- case inputFile ps of+ Just f -> case takeExtension f of+ ".gz" -> (liftM GZip.decompress . BS.readFile) f+ _ -> BS.readFile f+ Nothing -> BS.hGetContents stdin+ let (_, p) = communicationParsers ! (format ps)+ oh <- case outputFile ps of+ Just f -> openFile f WriteMode+ Nothing -> return stdout+ cs <- ingest (writeCommunication oh) p (decodeUtf8 ih) (contentSectionTypes ps) (commId ps) (commType ps)+ return ()+ where+ opts = info (helper <*> parameters)+ ( fullDesc+ <> progDesc "Ingest Concrete Communications from various formats"+ )
− utils/IngestJson.hs
@@ -1,256 +0,0 @@-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, GADTs, MultiParamTypeClasses, FlexibleInstances, RecordWildCards #-}-module Main (main) where--import qualified Data.ByteString.Lazy as BS-import Control.Monad.IO.Class (liftIO)-import qualified Data.Map as M-import Data.Functor (($>))-import Data.List (intercalate)-import Control.Applicative (empty)-import Data.Monoid ((<>))-import Control.Monad (void, join, liftM)-import Data.Text.Lazy (Text, unpack, take)-import qualified Data.Text.Lazy as T-import Data.Text.Lazy.Encoding (decodeUtf8)-import Data.Vector (Vector, fromList, snoc, empty)-import Data.List (isSuffixOf, reverse, drop)-import qualified Control.Monad.State as S-import qualified Control.Monad.Identity as I-import qualified Data.List.NonEmpty as NE--import System.FilePath (takeExtension)-import qualified Codec.Compression.GZip as GZip--import qualified Options.Applicative as O-import Options.Applicative (option, auto, short, long, metavar, strOption, help, execParser, info, helper, fullDesc, progDesc, many)--import Text.Megaparsec.Char (spaceChar, char)-import qualified Text.Megaparsec.Lexer as L-import Text.Megaparsec.Combinator (choice, sepBy, sepBy1, between)-import Text.Megaparsec.Error (Dec)-import Text.Megaparsec.Pos (defaultTabWidth)-import Text.Megaparsec.Prim (Parsec, ParsecT, setTokensProcessed)-import Text.Megaparsec ( parseErrorPretty- , many- , eof- , (<|>)- , space- , try- , hexDigitChar- , count- , manyTill- , anyChar- , getParserState- , State(..)- , ParsecT- , SourcePos(..)- , Pos(..)- , initialPos- , runParserT- , runParserT'- , some- )--import Data.Concrete ( read_Communication- , write_Communication- , default_Communication- , Communication(..)- , default_Section- , Section(..)- , default_AnnotationMetadata- , AnnotationMetadata(..)- , default_CommunicationMetadata- , CommunicationMetadata(..)- , default_Sentence- , Sentence(..)- , default_TextSpan- , TextSpan(..)- )--import qualified Data.Concrete.Utils as CU-import qualified Data.Concrete as C--type Parser = Parsec Dec Text--data JSON = JNumber Double- | JString String- | JArray [JSON]- | JObject (M.Map String JSON)- | JBool Bool- | JNull- deriving (Show)--data BuildState = BuildState { path :: [String]- , sections :: [Section]- , comms :: [Communication]- , offset :: Int- , id :: Maybe String- }--type CommunicationParser a = ParsecT Dec Text (S.StateT BuildState IO) a --jsonCP :: CommunicationParser JSON-jsonCP = do- s <- (fromIntegral . stateTokensProcessed) <$> getParserState - j <- lexeme $ choice [nullP, numberP, stringP, boolP, objectP, arrayP]- e <- (fromIntegral . stateTokensProcessed) <$> getParserState- bs@(BuildState {..}) <- S.get- uuid <- liftIO CU.getUUID- let path' = T.pack (intercalate "." (reverse path))- section = default_Section { section_uuid=uuid- , section_label=Just path'- , section_textSpan=Just $ TextSpan (s - (fromIntegral offset)) (e - (fromIntegral offset))- , section_kind="metadata"- }- S.put $ bs { sections=section:sections }- return j--nullP = do- symbol "null"- return $ JNull- -boolP = do- c <- symbol "true" <|> symbol "false"- return $ JBool (c == "true")- -numberP = do- c <- L.signed (pure ()) (try L.float <|> (fromInteger <$> L.integer))- return $ JNumber c--escapedChar = do- char '\\'- choice [- char '\"' $> '\"', -- A boring list of hardcoded values from the spec.- char '\\' $> '\\',- char '/' $> '/' ,- char 'n' $> '\n',- char 'r' $> '\r',- char 'f' $> '\f',- char 't' $> '\t',- char 'b' $> '\b',- unicodeEscape ]--unicodeEscape = do- char 'u'- code <- count 4 hexDigitChar- return $ toEnum (read ("0x" ++ code))--stringLiteral = lexeme $ do - char '\"'- (escapedChar <|> anyChar) `manyTill` char '\"'--stringP = do- c <- stringLiteral- return $ JString c--arrayEntryP = do- bs@(BuildState{..}) <- S.get- let p = (read $ head path) :: Int- S.put $ bs { path=(show (p + 1)):(tail path) } - jsonCP- -arrayP = do- S.modify' (\ bs@(BuildState{..}) -> bs { path=(show (-1)):path })- c <- brackets (arrayEntryP `sepBy` comma)- S.modify' (\ bs@(BuildState{..}) -> bs { path=tail path})- return $ JArray c- -pairP = do- key <- stringLiteral- symbol ":"- S.modify' (\ bs@(BuildState{..}) -> bs { path=key:path })- value <- jsonCP- S.modify' (\ bs@(BuildState{..}) -> bs { path=tail path})- return (key, value)--objectP = do- c <- M.fromList <$> braces (pairP `sepBy` comma)- return $ JObject c--topLevelObjectP t = do- offset <- (fromIntegral . stateTokensProcessed) <$> getParserState- S.modify (\bs -> bs { offset=offset })- objectP- end <- (fromIntegral . stateTokensProcessed) <$> getParserState- let t' = substr t offset end- uuid <- liftIO CU.getUUID- S.modify (\ bs@(BuildState{..}) -> bs { sections=[]- , comms=(default_Communication { communication_id=C.uUID_uuidString uuid- , communication_uuid=uuid- , communication_text=Just $ T.pack t'- , communication_sectionList=(Just . fromList . reverse) sections- }):comms- })--symbol = L.symbol space-brackets = between (symbol "[") (symbol "]")-braces = between (symbol "{") (symbol "}")-lexeme = L.lexeme space-comma = symbol ","--substr :: Text -> Int -> Int -> String-substr t s e = unpack res- where- (_, start) = T.splitAt (fromIntegral s) t - res = T.take (fromIntegral $ e - s) start--data Parameters = Parameters { inputFile :: String- , outputFile :: String- , commType :: String- , commId :: String- , contentSectionTypes :: [String]- } deriving (Show)--parameters :: O.Parser Parameters-parameters = Parameters- <$> strOption (short 'i'- <> long "input"- <> metavar "INPUT_FILE"- <> help "Text file of JSON objects"- )- <*> strOption (short 'o'- <> long "output"- <> metavar "OUTPUT_FILE"- <> help "Tar archive of Concrete Communications"- )- <*> strOption (short 't'- <> long "commType"- <> metavar "COMMUNICATION_TYPE"- <> help "String describing the type of Communication(s)"- )- <*> strOption (short 'I'- <> long "commId"- <> metavar "COMMUNICATION_ID"- <> help "String describing the Communication ID"- )- <*> many (strOption (short 's'- <> long "contentSectionTypes"- <> metavar "CONTENT_SECTION_TYPES"- <> help "The names of sections to be considered \"content\" rather than \"metadata\""- ))--parseComms :: Text -> IO [Communication]-parseComms t = do- let s = State { stateInput=t- , statePos=NE.fromList $ [initialPos "JSON"]- , stateTokensProcessed=0- , stateTabWidth=defaultTabWidth- }- unwrapped = between space eof (some (topLevelObjectP t))- wrapped = between space eof (brackets ((topLevelObjectP t) `sepBy` comma))- (r, BuildState _ _ cs _ _) <- (S.runStateT (runParserT' (wrapped <|> unwrapped) s) (BuildState [] [] [] 0 Nothing))- return cs--main = do- ps <- execParser opts- let f = inputFile ps- t <- decodeUtf8 <$> case takeExtension f of- ".gz" -> (liftM GZip.decompress . BS.readFile) f- _ -> BS.readFile f- cs <- parseComms t- CU.writeCommunications (outputFile ps) cs- where - opts = info (helper <*> parameters)- ( fullDesc- <> progDesc "Ingest JSON into Concrete Communications"- )
utils/InspectCommunication.hs view
@@ -23,31 +23,11 @@ <> help "Text file of JSON objects" ) -showSection :: T.Text -> C.Section -> String-showSection t s = "\t" ++ ((T.unpack . fromJust . C.section_label) s) ++ "--->" ++ t'- where- C.TextSpan s' e' = (fromJust . C.section_textSpan) s- t' = substr t (fromIntegral s') (fromIntegral e') -showCommunication :: C.Communication -> String-showCommunication c = (T.unpack $ (C.communication_id c)) ++ "\n" ++ (intercalate "\n" sects) ++ "\n"- where- ss = concat $ map V.toList (maybeToList (C.communication_sectionList c))- t = (fromJust . C.communication_text) c- sects = map (showSection t) ss---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- main = do ps <- execParser opts cs <- CU.readCommunications (inputFile ps)- putStr $ intercalate "\n" (map show cs) ++ "\n"- putStr $ intercalate "\n" [showCommunication c | c <- cs] ++ "\n"+ putStr $ ((T.unpack . T.concat) $ map CU.showCommunication cs) where opts = info (helper <*> parameters) ( fullDesc