-- | XDR Parser for .x files, as per RFC4506 and RPC extensions from RFC5531

{-# LANGUAGE TupleSections #-}
module Network.ONCRPC.XDR.Parse
  ( Binding(..)
  , Scope
  , parse
  ) where

import           Control.Applicative ((<|>))
import           Control.Arrow ((***), second)
import           Control.Monad (void, join, liftM2)
import qualified Data.ByteString.Lazy as BSL
import           Data.Char (digitToInt, isLower, isUpper, toLower, toUpper)
import           Data.Functor.Identity (Identity)
import qualified Data.Map as Map
import           Data.Maybe (catMaybes, mapMaybe)
import qualified Data.Set as Set
import qualified Text.Parsec as P
import qualified Text.Parsec.Token as PT

import qualified Network.ONCRPC.XDR.Types as XDR
import           Network.ONCRPC.XDR.Specification hiding (arrayLength)

data Binding = Binding
  { Binding -> Bool
bindingInitCaseConflict :: !Bool -- ^Same name as another identifier modulo first character case
  , Binding -> DefinitionBody
bindingDefinition :: !DefinitionBody
  }

type Scope = Map.Map String Binding
type Stream = BSL.ByteString
type Parser = P.Parsec Stream Scope

tupleM :: Monad m => m a -> m b -> m (a, b)
tupleM :: forall (m :: * -> *) a b. Monad m => m a -> m b -> m (a, b)
tupleM = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)

baseScope :: Scope
baseScope :: Scope
baseScope = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
  (String
"bool",   Bool -> DefinitionBody -> Binding
Binding Bool
False forall a b. (a -> b) -> a -> b
$ TypeDescriptor -> DefinitionBody
TypeDef forall a b. (a -> b) -> a -> b
$ TypeSpecifier -> TypeDescriptor
TypeSingle forall a b. (a -> b) -> a -> b
$ EnumBody -> TypeSpecifier
TypeEnum forall a b. (a -> b) -> a -> b
$ EnumValues -> EnumBody
EnumBody forall a b. (a -> b) -> a -> b
$ EnumValues
boolValues)
  forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a
id forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Bool -> DefinitionBody -> Binding
Binding Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDescriptor -> DefinitionBody
TypeDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSpecifier -> TypeDescriptor
TypeSingle)
    [ (String
"int",       TypeSpecifier
TypeInt)
    , (String
"unsigned",  TypeSpecifier
TypeUnsignedInt)
    , (String
"hyper",     TypeSpecifier
TypeHyper)
    , (String
"float",     TypeSpecifier
TypeFloat)
    , (String
"double",    TypeSpecifier
TypeDouble)
    , (String
"quadruple", TypeSpecifier
TypeQuadruple)
    ]
  forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. (a -> b) -> a -> b
$ Bool -> DefinitionBody -> Binding
Binding Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DefinitionBody
Constant forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger) EnumValues
boolValues

toggleCase :: String -> String
toggleCase :: String -> String
toggleCase (Char
c:String
s)
  | Char -> Bool
isUpper Char
c = Char -> Char
toLower Char
cforall a. a -> [a] -> [a]
:String
s
  | Char -> Bool
isLower Char
c = Char -> Char
toUpper Char
cforall a. a -> [a] -> [a]
:String
s
toggleCase String
s = String
s

addScope :: Definition -> Parser ()
addScope :: Definition -> Parser ()
addScope (Definition String
i DefinitionBody
b) = do
  case DefinitionBody
b of
    TypeDef TypeDescriptor
t -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ TypeDescriptor -> Parser TypeDescriptor
resolveTypeDescriptor TypeDescriptor
t
    DefinitionBody
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Scope
s <- forall (m :: * -> *) s u. Monad m => ParsecT s u m u
P.getState
  case forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (forall a b. a -> b -> a
const forall a b. a -> b -> a
const) String
i (Bool -> DefinitionBody -> Binding
Binding (forall k a. Ord k => k -> Map k a -> Bool
Map.member (String -> String
toggleCase String
i) Scope
s) DefinitionBody
b) Scope
s of
    (Maybe Binding
Nothing, Scope
s') -> forall (m :: * -> *) u s. Monad m => u -> ParsecT s u m ()
P.putState Scope
s'
    (Maybe Binding, Scope)
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"duplicate identifier: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
i

checkInt :: (MonadFail m, Integral n) => Integer -> m n
checkInt :: forall (m :: * -> *) n. (MonadFail m, Integral n) => Integer -> m n
checkInt Integer
n
  | Integer
n forall a. Eq a => a -> a -> Bool
== forall a. Integral a => a -> Integer
toInteger n
n' = forall (m :: * -> *) a. Monad m => a -> m a
return n
n'
  | Bool
otherwise = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid constant"
  where n' :: n
n' = forall a. Num a => Integer -> a
fromInteger Integer
n

data Value
  = ValueIdentifier !String
  | ValueConstant !Integer
  deriving (Int -> Value -> String -> String
[Value] -> String -> String
Value -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Value] -> String -> String
$cshowList :: [Value] -> String -> String
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> String -> String
$cshowsPrec :: Int -> Value -> String -> String
Show)

resolveValue :: Integral n => Value -> Parser n
resolveValue :: forall n. Integral n => Value -> Parser n
resolveValue (ValueConstant Integer
n) = forall (m :: * -> *) n. (MonadFail m, Integral n) => Integer -> m n
checkInt Integer
n
resolveValue (ValueIdentifier String
v) = do
  Scope
s <- forall (m :: * -> *) s u. Monad m => ParsecT s u m u
P.getState
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
v Scope
s of
    Just (Binding Bool
_ (Constant Integer
n)) -> forall (m :: * -> *) n. (MonadFail m, Integral n) => Integer -> m n
checkInt Integer
n
    Maybe Binding
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"undefined constant: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
v

-- |Expand 'TypeSingle' 'TypeIdentifier'
resolveTypeDescriptor :: TypeDescriptor -> Parser TypeDescriptor
resolveTypeDescriptor :: TypeDescriptor -> Parser TypeDescriptor
resolveTypeDescriptor (TypeSingle (TypeIdentifier String
i)) = do
  Scope
s <- forall (m :: * -> *) s u. Monad m => ParsecT s u m u
P.getState
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
i Scope
s of
    Just (Binding Bool
_ (TypeDef TypeDescriptor
t)) -> TypeDescriptor -> Parser TypeDescriptor
resolveTypeDescriptor TypeDescriptor
t
    Maybe Binding
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"undefined type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
i
resolveTypeDescriptor TypeDescriptor
d = forall (m :: * -> *) a. Monad m => a -> m a
return TypeDescriptor
d

literalLetter :: Parser Char
literalLetter :: Parser Char
literalLetter = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.alphaNum forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'_'

token :: PT.GenTokenParser Stream Scope Identity
token :: GenTokenParser Stream Scope Identity
token = forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
PT.makeTokenParser PT.LanguageDef
  { commentStart :: String
PT.commentStart    = String
"/*"
  , commentEnd :: String
PT.commentEnd      = String
"*/"
  , commentLine :: String
PT.commentLine     = String
"%"
  , nestedComments :: Bool
PT.nestedComments  = Bool
False
  , identStart :: Parser Char
PT.identStart      = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.letter
  , identLetter :: Parser Char
PT.identLetter     = Parser Char
literalLetter
  , opStart :: Parser Char
PT.opStart         = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"token op"
  , opLetter :: Parser Char
PT.opLetter        = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"token op"
  , reservedNames :: [String]
PT.reservedNames   =
    [ String
"bool"
    , String
"case"
    , String
"const"
    , String
"default"
    , String
"double"
    , String
"quadruple"
    , String
"enum"
    , String
"float"
    , String
"hyper"
    , String
"int"
    , String
"opaque"
    , String
"string"
    , String
"struct"
    , String
"switch"
    , String
"typedef"
    , String
"union"
    , String
"unsigned"
    , String
"void"

    , String
"program"
    , String
"version"
    ]
  , reservedOpNames :: [String]
PT.reservedOpNames = []
  , caseSensitive :: Bool
PT.caseSensitive   = Bool
True
  }

reserved :: String -> Parser ()
reserved :: String -> Parser ()
reserved = forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m ()
PT.reserved GenTokenParser Stream Scope Identity
token

identifier :: Parser String
identifier :: Parser String
identifier = forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
PT.identifier GenTokenParser Stream Scope Identity
token

endSemi1 :: Parser a -> Parser [a]
endSemi1 :: forall a. Parser a -> Parser [a]
endSemi1 Parser a
p = Parser a
p forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`P.endBy1` forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
PT.semi GenTokenParser Stream Scope Identity
token

arrayLength, variableArrayLength :: Parser ArrayLength
variableArrayLength :: Parser ArrayLength
variableArrayLength =
  Length -> ArrayLength
VariableLength forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.angles GenTokenParser Stream Scope Identity
token (forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option Length
XDR.maxLength forall n. Integral n => Parser n
value)
arrayLength :: Parser ArrayLength
arrayLength =
  Length -> ArrayLength
FixedLength    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.brackets GenTokenParser Stream Scope Identity
token forall n. Integral n => Parser n
value
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ArrayLength
variableArrayLength

declaration :: Parser Declaration
declaration :: Parser Declaration
declaration =
      Parser Declaration
typeDeclaration
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Declaration
opaqueDeclaration
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Declaration
stringDeclaration
  where
  typeDeclaration :: Parser Declaration
typeDeclaration = do
    TypeSpecifier
t <- Parser TypeSpecifier
typeSpecifier
    String -> TypeDescriptor -> Declaration
Declaration
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m String
PT.symbol GenTokenParser Stream Scope Identity
token String
"*" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
identifier)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeSpecifier -> TypeDescriptor
TypeOptional TypeSpecifier
t)
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> TypeDescriptor -> Declaration
Declaration
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
identifier
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TypeSpecifier -> ArrayLength -> TypeDescriptor
TypeArray TypeSpecifier
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ArrayLength
arrayLength forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (TypeSpecifier -> TypeDescriptor
TypeSingle TypeSpecifier
t))
  opaqueDeclaration :: Parser Declaration
opaqueDeclaration =
    String -> TypeDescriptor -> Declaration
Declaration
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser ()
reserved String
"opaque" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
identifier)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ArrayLength -> TypeDescriptor
TypeOpaque forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ArrayLength
arrayLength)
  stringDeclaration :: Parser Declaration
stringDeclaration =
    String -> TypeDescriptor -> Declaration
Declaration
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser ()
reserved String
"string" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
identifier)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ArrayLength -> TypeDescriptor
TypeString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ArrayLength
variableArrayLength)

optionalDeclaration :: Parser OptionalDeclaration
optionalDeclaration :: Parser OptionalDeclaration
optionalDeclaration =
      forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Declaration
declaration
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"void"

constant :: Parser Integer
constant :: Parser Integer
constant = (forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.lexeme GenTokenParser Stream Scope Identity
token forall a b. (a -> b) -> a -> b
$
  forall {u}. ParsecT Stream u Identity Integer
nat forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'-' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {u}. ParsecT Stream u Identity Integer
dec))
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
P.<?> String
"constant" where
  nat :: ParsecT Stream u Identity Integer
nat = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'0' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
P.oneOf String
"xX" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {s} {m :: * -> *} {t} {u}.
Stream s m t =>
Integer -> ParsecT s u m Char -> ParsecT s u m Integer
number Integer
16 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.hexDigit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {s} {m :: * -> *} {t} {u}.
Stream s m t =>
Integer -> ParsecT s u m Char -> ParsecT s u m Integer
number Integer
8 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.octDigit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {u}. ParsecT Stream u Identity Integer
dec
  dec :: ParsecT Stream u Identity Integer
dec = forall {s} {m :: * -> *} {t} {u}.
Stream s m t =>
Integer -> ParsecT s u m Char -> ParsecT s u m Integer
number Integer
10 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.digit
  number :: Integer -> ParsecT s u m Char -> ParsecT s u m Integer
number Integer
base ParsecT s u m Char
digit = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Integer
x Char
d -> Integer
baseforall a. Num a => a -> a -> a
*Integer
x forall a. Num a => a -> a -> a
+ forall a. Integral a => a -> Integer
toInteger (Char -> Int
digitToInt Char
d)) Integer
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 ParsecT s u m Char
digit

value :: Integral n => Parser n
value :: forall n. Integral n => Parser n
value = forall n. Integral n => Value -> Parser n
resolveValue forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      Integer -> Value
ValueConstant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
constant
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Value
ValueIdentifier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
identifier

typeSpecifier :: Parser TypeSpecifier
typeSpecifier :: Parser TypeSpecifier
typeSpecifier = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
P.choice
  [ TypeSpecifier
TypeInt        forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"int"
  , TypeSpecifier
TypeHyper      forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"hyper"
  , String -> Parser ()
reserved String
"unsigned" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (
        TypeSpecifier
TypeUnsignedInt   forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"int"
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TypeSpecifier
TypeUnsignedHyper forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"hyper"
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return TypeSpecifier
TypeUnsignedInt)
  , TypeSpecifier
TypeFloat      forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"float"
  , TypeSpecifier
TypeDouble     forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"double"
  , TypeSpecifier
TypeQuadruple  forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"quadruple"
  , TypeSpecifier
TypeBool       forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"bool"
  , String -> Parser ()
reserved String
"enum"  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (EnumBody -> TypeSpecifier
TypeEnum   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EnumBody
enumBody   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TypeSpecifier
typeIdentifier)
  , String -> Parser ()
reserved String
"struct"forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (StructBody -> TypeSpecifier
TypeStruct forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser StructBody
structBody forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TypeSpecifier
typeIdentifier)
  , String -> Parser ()
reserved String
"union" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (UnionBody -> TypeSpecifier
TypeUnion  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser UnionBody
unionBody  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TypeSpecifier
typeIdentifier)
  , Parser TypeSpecifier
typeIdentifier
  ] where
  typeIdentifier :: Parser TypeSpecifier
typeIdentifier = String -> TypeSpecifier
TypeIdentifier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
identifier

checkUnique :: (Ord k, Show k) => String -> [k] -> Parser (Set.Set k)
checkUnique :: forall k. (Ord k, Show k) => String -> [k] -> Parser (Set k)
checkUnique String
t = forall {m :: * -> *} {a}.
(Ord a, MonadFail m, Show a) =>
Set a -> [a] -> m (Set a)
ui forall a. Set a
Set.empty where
  ui :: Set a -> [a] -> m (Set a)
ui Set a
m [] = forall (m :: * -> *) a. Monad m => a -> m a
return Set a
m
  ui Set a
m (a
k:[a]
l)
    | forall a. Ord a => a -> Set a -> Bool
Set.member a
k Set a
m = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"duplicate " forall a. [a] -> [a] -> [a]
++ String
t forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
k
    | Bool
otherwise = Set a -> [a] -> m (Set a)
ui (forall a. Ord a => a -> Set a -> Set a
Set.insert a
k Set a
m) [a]
l

enumBody :: Parser EnumBody
enumBody :: Parser EnumBody
enumBody = do
  EnumValues
l <- forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.braces GenTokenParser Stream Scope Identity
token forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m [a]
PT.commaSep1 GenTokenParser Stream Scope Identity
token forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m (a, b)
tupleM Parser String
identifier (forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m String
PT.symbol GenTokenParser Stream Scope Identity
token String
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. Integral n => Parser n
value)
  Set String
_ <- forall k. (Ord k, Show k) => String -> [k] -> Parser (Set k)
checkUnique String
"enum identifier" forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumValues
l
  Set Int
_ <- forall k. (Ord k, Show k) => String -> [k] -> Parser (Set k)
checkUnique String
"enum value" forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumValues
l
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(String
i, Int
v) -> Definition -> Parser ()
addScope forall a b. (a -> b) -> a -> b
$ String -> DefinitionBody -> Definition
Definition String
i forall a b. (a -> b) -> a -> b
$ Integer -> DefinitionBody
Constant forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Integer
toInteger Int
v) EnumValues
l
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ EnumValues -> EnumBody
EnumBody EnumValues
l

structBody :: Parser StructBody
structBody :: Parser StructBody
structBody = do
  [Declaration]
l <- forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.braces GenTokenParser Stream Scope Identity
token forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser [a]
endSemi1 Parser OptionalDeclaration
optionalDeclaration
  Set String
_ <- forall k. (Ord k, Show k) => String -> [k] -> Parser (Set k)
checkUnique String
"struct member" forall a b. (a -> b) -> a -> b
$ Declaration -> String
declarationIdentifier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration]
l
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Declaration] -> StructBody
StructBody [Declaration]
l

unionBody :: Parser UnionBody
unionBody :: Parser UnionBody
unionBody = do
  String -> Parser ()
reserved String
"switch"
  Declaration
d <- forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.parens GenTokenParser Stream Scope Identity
token Parser Declaration
declaration
  TypeDescriptor
r <- TypeDescriptor -> Parser TypeDescriptor
resolveTypeDescriptor forall a b. (a -> b) -> a -> b
$ Declaration -> TypeDescriptor
declarationType Declaration
d
  ParsecT Stream Scope Identity Int
p <- case TypeDescriptor
r of
    TypeSingle TypeSpecifier
TypeInt -> forall (m :: * -> *) a. Monad m => a -> m a
return forall n. Integral n => Parser n
value
    TypeSingle TypeSpecifier
TypeUnsignedInt -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall n. Integral n => Parser n
value :: Parser XDR.UnsignedInt)
    TypeSingle TypeSpecifier
TypeBool -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a} {m :: * -> *} {a}.
(Foldable t, Eq a, MonadFail m) =>
t (a, a) -> a -> m a
valid EnumValues
boolValues forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall n. Integral n => Parser n
value
    TypeSingle (TypeEnum (EnumBody EnumValues
v)) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a} {m :: * -> *} {a}.
(Foldable t, Eq a, MonadFail m) =>
t (a, a) -> a -> m a
valid EnumValues
v forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall n. Integral n => Parser n
value
    TypeDescriptor
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid discriminant declaration"
  forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.braces GenTokenParser Stream Scope Identity
token forall a b. (a -> b) -> a -> b
$ do
    [(EnumValues, OptionalDeclaration)]
l <- forall a. Parser a -> Parser [a]
endSemi1 (forall (m :: * -> *) a b. Monad m => m a -> m b -> m (a, b)
tupleM
      (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall a b. (a -> b) -> a -> b
$ String -> Parser ()
reserved String
"case" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a b. Monad m => m a -> m b -> m (a, b)
tupleM (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
P.lookAhead forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 Parser Char
literalLetter) ParsecT Stream Scope Identity Int
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
PT.colon GenTokenParser Stream Scope Identity
token)
      Parser OptionalDeclaration
optionalDeclaration)
    Set String
_ <- forall k. (Ord k, Show k) => String -> [k] -> Parser (Set k)
checkUnique String
"union member" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Declaration -> String
declarationIdentifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(EnumValues, OptionalDeclaration)]
l
    Set Int
_ <- forall k. (Ord k, Show k) => String -> [k] -> Parser (Set k)
checkUnique String
"union case" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(EnumValues, OptionalDeclaration)]
l
    Maybe UnionArm
f <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe forall a b. (a -> b) -> a -> b
$ String -> OptionalDeclaration -> UnionArm
UnionArm String
"default" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser ()
reserved String
"default" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
PT.colon GenTokenParser Stream Scope Identity
token forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser OptionalDeclaration
optionalDeclaration forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
PT.semi GenTokenParser Stream Scope Identity
token)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Declaration -> [(Int, UnionArm)] -> Maybe UnionArm -> UnionBody
UnionBody Declaration
d [ (Int
c, String -> OptionalDeclaration -> UnionArm
UnionArm String
s OptionalDeclaration
b) | (EnumValues
cs, OptionalDeclaration
b) <- [(EnumValues, OptionalDeclaration)]
l, (String
s, Int
c) <- EnumValues
cs ] Maybe UnionArm
f
  where
  valid :: t (a, a) -> a -> m a
valid t (a, a)
l a
n
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((a
n forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) t (a, a)
l = forall (m :: * -> *) a. Monad m => a -> m a
return a
n
    | Bool
otherwise = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid enum value"

procedure :: Parser Procedure
procedure :: Parser Procedure
procedure = Maybe TypeSpecifier
-> String -> [TypeSpecifier] -> Length -> Procedure
Procedure
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe TypeSpecifier)
optionalType
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String
identifier
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.parens GenTokenParser Stream Scope Identity
token (forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m [a]
PT.commaSep1 GenTokenParser Stream Scope Identity
token Parser (Maybe TypeSpecifier)
optionalType)
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m String
PT.symbol GenTokenParser Stream Scope Identity
token String
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. Integral n => Parser n
value)
  where 
  optionalType :: Parser (Maybe TypeSpecifier)
  optionalType :: Parser (Maybe TypeSpecifier)
optionalType =
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TypeSpecifier
typeSpecifier
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Parser ()
reserved String
"void"

programVersion :: Parser Version
programVersion :: Parser Version
programVersion = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join String -> String -> [Procedure] -> Length -> Version
Version
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser ()
reserved String
"version" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
identifier)
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.braces GenTokenParser Stream Scope Identity
token (forall a. Parser a -> Parser [a]
endSemi1 Parser Procedure
procedure)
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m String
PT.symbol GenTokenParser Stream Scope Identity
token String
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. Integral n => Parser n
value)

def :: Parser Definition
def :: Parser Definition
def = Parser Definition
constantDef forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Definition
typeDef forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Definition
programDef where
  constantDef :: Parser Definition
constantDef = String -> DefinitionBody -> Definition
Definition
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser ()
reserved String
"const" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
identifier)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m String
PT.symbol GenTokenParser Stream Scope Identity
token String
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> DefinitionBody
Constant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
constant))
  typeDef :: Parser Definition
typeDef =
        String -> Parser ()
reserved String
"typedef" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Declaration -> Definition
declDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Declaration
declaration)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> DefinitionBody -> Definition
Definition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser ()
reserved String
"enum"   forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
identifier) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TypeDescriptor -> DefinitionBody
TypeDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSpecifier -> TypeDescriptor
TypeSingle forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumBody -> TypeSpecifier
TypeEnum   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser EnumBody
enumBody)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> DefinitionBody -> Definition
Definition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser ()
reserved String
"struct" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
identifier) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TypeDescriptor -> DefinitionBody
TypeDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSpecifier -> TypeDescriptor
TypeSingle forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructBody -> TypeSpecifier
TypeStruct forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser StructBody
structBody)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> DefinitionBody -> Definition
Definition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser ()
reserved String
"union"  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
identifier) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TypeDescriptor -> DefinitionBody
TypeDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSpecifier -> TypeDescriptor
TypeSingle forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnionBody -> TypeSpecifier
TypeUnion  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser UnionBody
unionBody)
  declDef :: Declaration -> Definition
declDef (Declaration String
i TypeDescriptor
t) = String -> DefinitionBody -> Definition
Definition String
i forall a b. (a -> b) -> a -> b
$ TypeDescriptor -> DefinitionBody
TypeDef TypeDescriptor
t
  programDef :: Parser Definition
programDef = do
    String -> Parser ()
reserved String
"program"
    String
i <- Parser String
identifier
    String -> DefinitionBody -> Definition
Definition String
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> [Version] -> Length -> DefinitionBody
Program String
i
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
PT.braces GenTokenParser Stream Scope Identity
token (forall a. Parser a -> Parser [a]
endSemi1 Parser Version
programVersion)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m String
PT.symbol GenTokenParser Stream Scope Identity
token String
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. Integral n => Parser n
value))

definition :: Parser Definition
definition :: Parser Definition
definition = do
  Definition
d <- Parser Definition
def
  Definition -> Parser ()
addScope Definition
d
  forall (m :: * -> *) a. Monad m => a -> m a
return Definition
d

specification :: Parser Specification
specification :: Parser Specification
specification = forall a. Parser a -> Parser [a]
endSemi1 Parser Definition
definition

file :: Parser (Specification, Scope)
file :: Parser (Specification, Scope)
file = forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
PT.whiteSpace GenTokenParser Stream Scope Identity
token forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a b. Monad m => m a -> m b -> m (a, b)
tupleM Parser Specification
specification forall (m :: * -> *) s u. Monad m => ParsecT s u m u
P.getState forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof

parse :: String -> BSL.ByteString -> Either P.ParseError (Specification, Scope)
parse :: String -> Stream -> Either ParseError (Specification, Scope)
parse = forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
P.runParser Parser (Specification, Scope)
file Scope
baseScope