{-# 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
, 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
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