{-# 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"
)