concrete-haskell 0.1.0.7 → 0.1.0.8
raw patch · 9 files changed
+475/−25 lines, 9 files
Files
- concrete-haskell.cabal +8/−4
- src/Data/Concrete/Parsers.hs +12/−3
- src/Data/Concrete/Parsers/CSV.hs +106/−0
- src/Data/Concrete/Parsers/Email.hs +106/−0
- src/Data/Concrete/Parsers/HTML.hs +105/−0
- src/Data/Concrete/Parsers/XML.hs +106/−0
- src/Data/Concrete/Utils.hs +4/−4
- utils/IngestCommunications.hs +4/−3
- utils/InspectCommunication.hs +24/−11
concrete-haskell.cabal view
@@ -1,5 +1,5 @@ name: concrete-haskell-version: 0.1.0.7+version: 0.1.0.8 synopsis: Library for the Concrete data format. description: Library for the Concrete data format. homepage: https://github.com/hltcoe@@ -17,11 +17,15 @@ exposed-modules: Data.Concrete , Data.Concrete.Types , Data.Concrete.Utils- , Data.Concrete.Parsers + , Data.Concrete.Parsers , Data.Concrete.Parsers.Types- , Data.Concrete.Parsers.Utils + , Data.Concrete.Parsers.Utils , Data.Concrete.Parsers.JSON- , Data.Concrete.Parsers.CONLL + , Data.Concrete.Parsers.CONLL+ , Data.Concrete.Parsers.Email+ , Data.Concrete.Parsers.XML+ , Data.Concrete.Parsers.CSV+ , Data.Concrete.Parsers.HTML other-modules: Communication_Types , Access_Types , Annotate_Types
src/Data/Concrete/Parsers.hs view
@@ -34,17 +34,26 @@ 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)+import qualified Data.Concrete.Parsers.JSON as JSON+import qualified Data.Concrete.Parsers.CONLL as CONLL+import qualified Data.Concrete.Parsers.HTML as HTML+import qualified Data.Concrete.Parsers.XML as XML+import qualified Data.Concrete.Parsers.CSV as CSV+import qualified Data.Concrete.Parsers.Email as Email + communicationParsers = Map.fromList [ ("JSON", ("JSON array of arbitrary objects", JSON.arrayOfObjectsP))- , ("CONLL", ("CONLL format", CONLL.arrayOfObjectsP))+ -- , ("CONLL", ("CONLL format", CONLL.arrayOfObjectsP))+ -- , ("HTML", ("HTML format", HTML.arrayOfObjectsP))+ -- , ("XML", ("XML format", XML.arrayOfObjectsP))+ -- , ("CSV", ("CSV format", CSV.arrayOfObjectsP))+ -- , ("Email", ("Email format", Email.arrayOfObjectsP)) ] ingest :: CommunicationAction -> CommunicationParser a -> Text -> [String] -> String -> String -> IO ()
+ src/Data/Concrete/Parsers/CSV.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings, ApplicativeDo #-}+module Data.Concrete.Parsers.CSV+ ( 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/Email.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings, ApplicativeDo #-}+module Data.Concrete.Parsers.Email+ ( 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/HTML.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+module Data.Concrete.Parsers.HTML+ ( 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/XML.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings, ApplicativeDo #-}+module Data.Concrete.Parsers.XML+ ( 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/Utils.hs view
@@ -3,7 +3,7 @@ ( getUUID , createAnnotationMetadata- , readCommunications+ , readCommunicationsFromBytes , writeCommunications , writeCommunication , showCommunication@@ -60,9 +60,9 @@ t <- commToString c (BS.hPutStr out . GZip.compress) t -readCommunications :: String -> IO [Communication]-readCommunications f = do- t <- (liftM GZip.decompress . BS.readFile) f+readCommunicationsFromBytes :: BS.ByteString -> IO [Communication]+readCommunicationsFromBytes t = do+ --t <- (liftM GZip.decompress . BS.readFile) f transport <- newTString fillBuf (getRead transport) t let iproto = CompactProtocol transport
utils/IngestCommunications.hs view
@@ -3,8 +3,9 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS-import Data.Map (toList, (!))+import Data.Map (toList, (!), keys) import Data.Monoid ((<>))+import Data.List (intercalate) import Control.Monad (void, join, liftM) import Data.Text.Lazy (Text, unpack, take) import Data.Text.Lazy.Encoding (decodeUtf8)@@ -51,7 +52,7 @@ <*> (optional $ strOption (short 'o' <> long "output" <> metavar "OUTPUT_FILE"- <> help "Tar archive of Concrete Communications"+ <> help "Where to write the Concrete Communications" ) ) <*> strOption (short 't'@@ -71,7 +72,7 @@ )) <*> strOption (short 'f' <> long "format"- <> help "Input format"+ <> help ("Input format: (" ++ ((intercalate "|" . keys) communicationParsers) ++ ")") ) main = do
utils/InspectCommunication.hs view
@@ -2,32 +2,45 @@ module Main (main) where import Data.Monoid ((<>))+import qualified Data.ByteString.Lazy as BS+import qualified Codec.Compression.GZip as GZip import qualified Data.Concrete.Utils as CU import qualified Data.Concrete as C import qualified Options.Applicative as O import Options.Applicative (option, auto, short, long, metavar, strOption, help, execParser, info, helper, fullDesc, progDesc, many) import qualified Data.Vector as V-import Control.Monad (liftM, mapM)+import Control.Monad (liftM, mapM, join) import Data.List (intercalate, concat) import qualified Data.Text.Lazy as T import Data.Maybe (fromJust, catMaybes, maybeToList)--data Parameters = Parameters { inputFile :: String+import System.IO (stdin, stdout, stderr, openFile, Handle, IOMode(..), hPutStrLn)+import System.FilePath (takeExtension)+data Parameters = Parameters { inputFile :: Maybe String } deriving (Show) parameters :: O.Parser Parameters parameters = Parameters- <$> strOption (short 'i'- <> long "input"- <> metavar "INPUT_FILE"- <> help "Text file of JSON objects"- )-+ <$> (O.optional $ strOption (short 'i'+ <> long "input"+ <> metavar "INPUT_FILE"+ <> help "Communications to inspect, serialized with Compact protocol, where the file name is interpreted by ending (.zip, .gz, .tgz) backing off to uncompressed sequence of Communications. If ommitted, read uncompressed sequence of Communications from stdin."+ )+ ) main = do ps <- execParser opts- cs <- CU.readCommunications (inputFile ps)- putStr $ ((T.unpack . T.concat) $ map CU.showCommunication cs)+ cs <- case inputFile ps of+ Just f -> case takeExtension f of+ ".tar" -> error "tar not implemented yet"+ ".tgz" -> error "compressed tar not implemented yet"+ ".tbz2" -> error "compressed tar not implemented yet"+ ".zip" -> error "zip not implemented yet"+ ".bz2" -> error "bzip not implemented yet"+ ".gz" -> CU.readCommunicationsFromBytes <$> ((liftM GZip.decompress . BS.readFile) f) + _ -> CU.readCommunicationsFromBytes <$> (BS.readFile f)+ Nothing -> CU.readCommunicationsFromBytes <$> (BS.hGetContents stdin)+ cs' <- cs+ putStr $ ((T.unpack . T.concat) $ map CU.showCommunication cs') where opts = info (helper <*> parameters) ( fullDesc