module DSS.Parser ( Discussion ( Discussion ) , Basiss ( Basiss ) , Label ( Label ) , Basis ( UrlBasis , BookBasis , QuoteBasis ) , Url ( Url ) , Book ( Book ) , Quote ( Quote ) , Isbn ( Isbn ) , Pages ( Pages ) , Claim ( Claim ) , ExpressionString ( StringExpression , QuoteExpression ) , Expression ( Expression ) , parse ) where
import Control.Applicative
import Data.List
import Text.Parser.Combinators
import qualified Text.Parser.Char as TPC
import qualified Text.ParserCombinators.ReadP as TPR
data Discussion = Discussion ( Maybe Expression ) Basiss Claim deriving ( Show , Read , Eq )
data Basiss = Basiss [ ( Maybe Label , Basis ) ] deriving ( Show , Read , Eq )
data Label = Label String deriving ( Show , Read , Eq )
data Basis = UrlBasis Url | BookBasis Book | QuoteBasis Quote deriving ( Show , Read , Eq )
data Url = Url String deriving ( Show , Read , Eq )
data Book = Book Isbn ( Maybe Pages ) deriving ( Show , Read , Eq )
data Quote = Quote [ ExpressionString ] deriving ( Show , Read , Eq )
data Isbn = Isbn String deriving ( Show , Read , Eq )
data Pages = Pages [ Int ] deriving ( Show , Read , Eq )
data Claim = Claim [ ExpressionString ] deriving ( Show , Read , Eq )
data ExpressionString = StringExpression String | QuoteExpression Expression deriving ( Show , Read , Eq )
data Expression = Expression [ String ] deriving ( Show , Read , Eq )
parse :: String -> [ Discussion ]
parse s = nub $ map fst $ TPR.readP_to_S discussion s
discussion :: TPR.ReadP Discussion
discussion = Discussion <$> optional opinion <*> basiss <*> claim
opinion :: TPR.ReadP Expression
opinion = do
_ <- many $ TPC.oneOf " \t\r\n"
_ <- TPC.string "opinion"
_ <- some $ TPC.oneOf " \t\r\n"
_ <- TPC.string "to"
_ <- some $ TPC.oneOf " \t\r\n"
between ( TPC.string "{" ) ( TPC.string "}" ) expression
basiss :: TPR.ReadP Basiss
basiss = Basiss <$> ( some ( ( , ) <$> optional label <*> basis ) )
label :: TPR.ReadP Label
label = do
_ <- many $ TPC.oneOf " \t\r\n"
l <- some $ TPC.noneOf " \t\r\n"
_ <- many $ TPC.oneOf " \t\r\n"
_ <- TPC.string ":"
return $ Label l
basis :: TPR.ReadP Basis
basis = choice [ UrlBasis <$> url , BookBasis <$> book , QuoteBasis <$> quote_discussion ]
url :: TPR.ReadP Url
url = do
_ <- many $ TPC.oneOf " \t\r\n"
_ <- TPC.string "url"
_ <- many $ TPC.oneOf " \t\r\n"
u <- uri
return $ Url u
book :: TPR.ReadP Book
book = do
_ <- many $ TPC.oneOf " \t\r\n"
_ <- TPC.string "ISBN"
i <- isbn
p <- optional pages
return $ Book i p
pages :: TPR.ReadP Pages
pages = do
_ <- many $ TPC.oneOf " \t\r\n"
_ <- TPC.string "pages"
_ <- many $ TPC.oneOf " \t\r\n"
b <- between ( TPC.string "(" ) ( TPC.string ")" ) page_numbers
return $ Pages b
page_numbers :: TPR.ReadP [ Int ]
page_numbers = do
_ <- many $ TPC.oneOf " \t\r\n"
p <- page_number
_ <- many $ TPC.oneOf " \t\r\n"
m <- many $ do
_ <- many $ TPC.oneOf " \t\r\n"
_ <- TPC.string ","
_ <- many $ TPC.oneOf " \t\r\n"
p' <- page_number
_ <- many $ TPC.oneOf " \t\r\n"
return p'
return $ p : m
page_number :: TPR.ReadP Int
page_number = do
d <- digit_
return $ read d
quote_discussion :: TPR.ReadP Quote
quote_discussion = do
_ <- many $ TPC.oneOf " \t\r\n"
_ <- TPC.string "text"
_ <- many $ TPC.oneOf " \t\r\n"
s <- string_
return $ Quote s
claim :: TPR.ReadP Claim
claim = do
_ <- many $ TPC.oneOf " \t\r\n"
_ <- TPC.string "claim"
_ <- many $ TPC.oneOf " \t\r\n"
s <- string_
return $ Claim s
digit_ :: TPR.ReadP String
digit_ = some $ TPC.oneOf [ '0' .. '9' ]
string_ :: TPR.ReadP [ ExpressionString ]
string_ = between ( TPC.string "\"" ) ( TPC.string "\"" ) string_body
string_body :: TPR.ReadP [ ExpressionString ]
string_body = do
c <- many $ choice [ StringExpression <$> ( TPC.noneOf "\"\\{}" >>= return . return ) , StringExpression <$> ( TPC.string "\\{" >> return "{" ) , StringExpression <$> ( TPC.string "\\}" >> return "}" ) , StringExpression <$> ( TPC.string "\\\\" >> return "\\" ) , StringExpression <$> ( TPC.string "\\\"" >> return "\"" ) , QuoteExpression <$> between ( TPC.string "{" ) ( TPC.string "}" ) expression ]
return $ foldr ( \ e l -> case ( e , l ) of
( StringExpression e' , StringExpression l' : ls ) -> StringExpression ( e' ++ l' ) : ls
_ -> e : l ) [ ] c
expression :: TPR.ReadP Expression
expression = do
f <- some $ TPC.noneOf ".{}"
post <- some $ TPC.string "." >> ( some $ TPC.noneOf ".{}" )
return $ Expression $ f : post
uri :: TPR.ReadP String
uri = do
sc <- scheme
colon <- TPC.string ":"
hp <- hier_part
q <- optional $ do
q' <- TPC.string "?"
q'' <- query
return $ q' ++ q''
f <- optional $ do
h <- TPC.string "#"
f' <- fragment
return $ h ++ f'
return $ sc ++ colon ++ hp ++ ( maybe "" id q ) ++ ( maybe "" id f )
hier_part :: TPR.ReadP String
hier_part = choice [ do {
ss <- TPC.string "//" ;
a <- authority ;
p <- path_abempty ;
return $ ss ++ a ++ p } , path_absolute , path_rootless , path_empty ]
scheme :: TPR.ReadP String
scheme = do
a <- alpha
m <- many $ choice [ alpha , digit , TPC.char '+' , TPC.char '-' , TPC.char '.' ]
return $ a : m
authority :: TPR.ReadP String
authority = do
s <- optional $ do
u <- userinfo
a <- TPC.string "@"
return $ u ++ a
h <- host
p <- optional $ do
c <- TPC.string ":"
p <- port
return $ c ++ p
return $ maybe "" id s ++ h ++ maybe "" id p
userinfo :: TPR.ReadP String
userinfo = ( many $ choice [ unreserved , pct_encoded , sub_delims , TPC.string ":" ] ) >>= return . concat
host :: TPR.ReadP String
host = choice [ ip_literal , ipv4address , reg_name ]
port :: TPR.ReadP String
port = many digit
ip_literal :: TPR.ReadP String
ip_literal = do
l <- TPC.string "["
a <- choice [ ipv6address , ipvfuture ]
r <- TPC.string "]"
return $ l ++ a ++ r
ipvfuture :: TPR.ReadP String
ipvfuture = do
v <- TPC.string "v"
h <- some hexdig
d <- TPC.string "."
s <- some $ choice [ unreserved , sub_delims , TPC.string ":" ]
return $ v ++ h ++ d ++ concat s
ipv6address :: TPR.ReadP String
ipv6address = choice [ do
r <- rep 6 6 $ do
h <- h16
c <- TPC.string ":"
return $ h ++ c
l <- ls32
return $ concat r ++ l , do
cc <- TPC.string "::"
r <- rep 5 5 $ do
h <- h16
c <- TPC.string ":"
return $ h ++ c
l <- ls32
return $ cc ++ concat r ++ l , do
o <- optional h16
s <- TPC.string "::"
r <- rep 4 4 $ do
h <- h16
s' <- TPC.string ":"
return $ h ++ s'
l <- ls32
return $ maybe "" id o ++ s ++ concat r ++ l , do
o <- optional $ do
r <- rep 0 1 $ do
h <- h16
s <- TPC.string ":"
return $ h ++ s
h <- h16
return $ concat r ++ h
s <- TPC.string "::"
r <- rep 3 3 $ do
h <- h16
s' <- TPC.string ":"
return $ h ++ s'
l <- ls32
return $ maybe "" id o ++ s ++ concat r ++ l , do
o <- optional $ do
r <- rep 0 2 $ do
h <- h16
s <- TPC.string ":"
return $ h ++ s
h <- h16
return $ concat r ++ h
s <- TPC.string "::"
r <- rep 2 2 $ do
h <- h16
s' <- TPC.string ":"
return $ h ++ s'
l <- ls32
return $ maybe "" id o ++ s ++ concat r ++ l , do
o <- optional $ do
r <- rep 0 3 $ do
h <- h16
s <- TPC.string ":"
return $ h ++ s
h <- h16
return $ concat r ++ h
s <- TPC.string "::"
h <- h16
s' <- TPC.string ":"
l <- ls32
return $ maybe "" id o ++ s ++ h ++ s' ++ l , do
o <- optional $ do
r <- rep 0 4 $ do
h <- h16
s <- TPC.string ":"
return $ h ++ s
h <- h16
return $ concat r ++ h
s <- TPC.string "::"
l <- ls32
return $ maybe "" id o ++ s ++ l , do
o <- optional $ do
r <- rep 0 5 $ do
h <- h16
s <- TPC.string ":"
return $ h ++ s
h <- h16
return $ concat r ++ h
s <- TPC.string "::"
h <- h16
return $ maybe "" id o ++ s ++ h , do
o <- optional $ do
r <- rep 0 6 $ do
h <- h16
s <- TPC.string ":"
return $ h ++ s
h <- h16
return $ concat r ++ h
s <- TPC.string "::"
return $ maybe "" id o ++ s ]
h16 :: TPR.ReadP String
h16 = rep 1 4 hexdig
ls32 :: TPR.ReadP String
ls32 = choice [ do
h <- h16
s <- TPC.string ":"
h' <- h16
return $ h ++ s ++ h' , ipv4address ]
ipv4address :: TPR.ReadP String
ipv4address = do
d <- dec_octet
s <- TPC.string "."
d' <- dec_octet
s' <- TPC.string "."
d'' <- dec_octet
s'' <- TPC.string "."
d''' <- dec_octet
return $ d ++ s ++ d' ++ s' ++ d'' ++ s'' ++ d'''
dec_octet :: TPR.ReadP String
dec_octet = choice [ digit >>= \ x -> return [ x ] , do
o <- TPC.oneOf [ '\x31' .. '\x39' ]
d <- digit
return $ [ o , d ] , do
s <- TPC.string "1"
r <- rep 2 2 digit
return $ s ++ r , do
s <- TPC.string "2"
o <- TPC.oneOf [ '\x30' .. '\x34' ]
d <- digit
return $ s ++ [ o ] ++ [ d ] , do
s <- TPC.string "25"
o <- TPC.oneOf [ '\x30' .. '\x35' ]
return $ s ++ [ o ] ]
reg_name :: TPR.ReadP String
reg_name = ( many $ choice [ unreserved , pct_encoded , sub_delims ] ) >>= return . concat
path_abempty :: TPR.ReadP String
path_abempty = do
m <- many $ do
s <- TPC.string "/"
s'<- segment
return $ s ++ s'
return $ concat m
path_absolute :: TPR.ReadP String
path_absolute = do
s <- TPC.string "/"
o <- optional $ do
s' <- segment_nz
m <- many $ do
s'' <- TPC.string "/"
s''' <- segment
return $ s'' ++ s'''
return $ s' ++ concat m
return $ s ++ maybe "" id o
path_rootless :: TPR.ReadP String
path_rootless = do
s <- segment_nz
m <- many $ do
s' <- TPC.string "/"
s'' <- segment
return $ s' ++ s''
return $ s ++ concat m
path_empty :: TPR.ReadP String
path_empty = rep 0 0 pchar >>= return . concat
segment :: TPR.ReadP String
segment = many pchar >>= return . concat
segment_nz :: TPR.ReadP String
segment_nz = some pchar >>= return . concat
pchar :: TPR.ReadP String
pchar = choice [ unreserved , pct_encoded , sub_delims , TPC.string ":" , TPC.string "@" ]
query :: TPR.ReadP String
query = ( many $ choice [ pchar , TPC.string "/" , TPC.string "?" ] ) >>= return . concat
fragment :: TPR.ReadP String
fragment = ( many $ choice [ pchar , TPC.string "/" , TPC.string "?" ] ) >>= return . concat
pct_encoded :: TPR.ReadP String
pct_encoded = do
s <- TPC.string "%"
h <- hexdig
h' <- hexdig
return $ s ++ [ h ] ++ [ h' ]
unreserved :: TPR.ReadP String
unreserved = choice [ alpha , digit , TPC.char '-' , TPC.char '.' , TPC.char '_' , TPC.char '~' ] >>= return . return
sub_delims :: TPR.ReadP String
sub_delims = choice [ TPC.string x | x <- [ "!" , "$" , "&" , "'" , "(" , ")" , "*" , "+" , "," , ";" , "=" ] ]
alpha :: TPR.ReadP Char
alpha = TPC.oneOf $ [ '\x41' .. '\x5A' ] ++ [ '\x61' .. '\x7A' ]
digit :: TPR.ReadP Char
digit = TPC.oneOf $ [ '\x30' .. '\x39' ]
hexdig :: TPR.ReadP Char
hexdig = TPC.oneOf $ [ '0' .. '9' ] ++ [ 'A' .. 'F' ] ++ [ 'a' .. 'f' ]
rep :: Int -> Int -> TPR.ReadP a -> TPR.ReadP [ a ]
rep n m r = choice [ count x r | x <- [ n .. m ] ]
isbn :: TPR.ReadP Isbn
isbn = do
_ <- many $ TPC.oneOf " \t\r\n"
s <- some digit
ss <- many $ do
_ <- TPC.string "-"
some digit
return $ Isbn $ concat $ s : ss