{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Network.ONCRPC.XDR.Generate
( generateFromFile
, generate
, generateModule
, ReidentOptions(..)
, GenerateOptions(..)
, defaultReidentOptions
) where
import Control.Arrow ((***), (&&&))
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Data.Char (isAlpha, isUpper)
import Data.Maybe (fromMaybe, maybeToList)
import qualified Language.Haskell.Exts.Build as HS
import Language.Haskell.Exts.Pretty (prettyPrintWithMode, PPHsMode(..), defaultMode)
import qualified Language.Haskell.Exts.Syntax as HS
import qualified Network.ONCRPC.XDR as XDR
import Network.ONCRPC.XDR.Specification
import qualified Network.ONCRPC.XDR.Parse as XDR
import Network.ONCRPC.XDR.Reident
name :: String -> HS.Name ()
name :: String -> Name ()
name s :: String
s@(~(Char
c:String
_))
| Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' = forall l. l -> String -> Name l
HS.Ident () String
s
| Bool
otherwise = forall l. l -> String -> Name l
HS.Symbol () String
s
infix 9 !, !.
(!) :: String -> String -> HS.QName ()
! :: String -> String -> QName ()
(!) String
"" = forall l. l -> Name l -> QName l
HS.UnQual () forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name ()
name
(!) String
m = forall l. l -> ModuleName l -> Name l -> QName l
HS.Qual () (forall l. l -> String -> ModuleName l
HS.ModuleName () String
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name ()
name
(!.) :: String -> String -> HS.Exp ()
!. :: String -> String -> Exp ()
(!.) String
m n :: String
n@(~(Char
c:String
_))
| Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
':' = forall l. l -> QName l -> Exp l
HS.Con () forall a b. (a -> b) -> a -> b
$ String
m String -> String -> QName ()
! String
n
| Bool
otherwise = forall l. l -> QName l -> Exp l
HS.Var () forall a b. (a -> b) -> a -> b
$ String
m String -> String -> QName ()
! String
n
instDecl :: HS.QName () -> String -> [HS.InstDecl ()] -> HS.Decl ()
instDecl :: QName () -> String -> [InstDecl ()] -> Decl ()
instDecl QName ()
c String
t = forall l.
l
-> Maybe (Overlap l) -> InstRule l -> Maybe [InstDecl l] -> Decl l
HS.InstDecl () forall a. Maybe a
Nothing
(forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
HS.IRule () forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall l. l -> InstHead l -> Type l -> InstHead l
HS.IHApp () (forall l. l -> QName l -> InstHead l
HS.IHCon () QName ()
c) forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
""String -> String -> QName ()
!String
t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
dataDecl :: String -> [HS.ConDecl ()] -> [String] -> HS.Decl ()
dataDecl :: String -> [ConDecl ()] -> [String] -> Decl ()
dataDecl String
n [ConDecl ()]
con [String]
derive = forall l.
l
-> DataOrNew l
-> Maybe (Context l)
-> DeclHead l
-> [QualConDecl l]
-> [Deriving l]
-> Decl l
HS.DataDecl () (forall l. l -> DataOrNew l
HS.DataType ()) forall a. Maybe a
Nothing (forall l. l -> Name l -> DeclHead l
HS.DHead () forall a b. (a -> b) -> a -> b
$ String -> Name ()
HS.name String
n)
(forall a b. (a -> b) -> [a] -> [b]
map (forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> ConDecl l
-> QualConDecl l
HS.QualConDecl () forall a. Maybe a
Nothing forall a. Maybe a
Nothing) [ConDecl ()]
con)
(forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l.
l -> Maybe (DerivStrategy l) -> [InstRule l] -> Deriving l
HS.Deriving ()
#if MIN_VERSION_haskell_src_exts(1,20,0)
forall a. Maybe a
Nothing
#endif
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
HS.IRule () forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> QName l -> InstHead l
HS.IHCon () forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Prelude"String -> String -> QName ()
!)) [String]
derive)
constantType :: HS.Type ()
constantType :: Type ()
constantType = forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
HS.TyForall ()
forall a. Maybe a
Nothing
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. l -> Asst l -> Context l
HS.CxSingle () forall a b. (a -> b) -> a -> b
$ forall l. l -> Type l -> Asst l
HS.TypeA () (forall l. l -> Type l -> Type l -> Type l
HS.TyApp () (forall l. l -> QName l -> Type l
HS.TyCon () (String
"Prelude"String -> String -> QName ()
!String
"Integral")) Type ()
t))
Type ()
t
where
t :: Type ()
t = forall l. l -> Name l -> Type l
HS.TyVar () forall a b. (a -> b) -> a -> b
$ String -> Name ()
HS.name String
"a"
primType :: TypeSpecifier -> Maybe String
primType :: TypeSpecifier -> Maybe String
primType TypeSpecifier
TypeInt = forall a. a -> Maybe a
Just String
"Int"
primType TypeSpecifier
TypeUnsignedInt = forall a. a -> Maybe a
Just String
"UnsignedInt"
primType TypeSpecifier
TypeHyper = forall a. a -> Maybe a
Just String
"Hyper"
primType TypeSpecifier
TypeUnsignedHyper = forall a. a -> Maybe a
Just String
"UnsignedHyper"
primType TypeSpecifier
TypeFloat = forall a. a -> Maybe a
Just String
"Float"
primType TypeSpecifier
TypeDouble = forall a. a -> Maybe a
Just String
"Double"
primType TypeSpecifier
TypeQuadruple = forall a. a -> Maybe a
Just String
"Quadruple"
primType TypeSpecifier
TypeBool = forall a. a -> Maybe a
Just String
"Bool"
primType TypeSpecifier
_ = forall a. Maybe a
Nothing
specType :: TypeSpecifier -> Maybe (HS.Type ())
specType :: TypeSpecifier -> Maybe (Type ())
specType (TypeIdentifier String
t) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
""String -> String -> QName ()
!String
t
specType TypeSpecifier
t = forall l. l -> QName l -> Type l
HS.TyCon () forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> QName ()
(!) String
"XDR" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeSpecifier -> Maybe String
primType TypeSpecifier
t
specType' :: TypeSpecifier -> HS.Type ()
specType' :: TypeSpecifier -> Type ()
specType' = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"parameter data structures are not supported") forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSpecifier -> Maybe (Type ())
specType
lengthType :: String -> XDR.Length -> HS.Type ()
lengthType :: String -> Length -> Type ()
lengthType String
t Length
l = forall l. l -> Type l -> Type l -> Type l
HS.TyApp () (forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
"XDR"String -> String -> QName ()
!String
t) forall a b. (a -> b) -> a -> b
$ forall l. l -> Promoted l -> Type l
HS.TyPromoted () forall a b. (a -> b) -> a -> b
$ forall l. l -> Integer -> String -> Promoted l
HS.PromotedInteger () (forall a. Integral a => a -> Integer
toInteger Length
l) (forall a. Show a => a -> String
show Length
l)
descrType :: TypeDescriptor -> Maybe (HS.Type ())
descrType :: TypeDescriptor -> Maybe (Type ())
descrType (TypeSingle TypeSpecifier
t) = TypeSpecifier -> Maybe (Type ())
specType TypeSpecifier
t
descrType (TypeArray TypeSpecifier
t (FixedLength Length
l)) = forall l. l -> Type l -> Type l -> Type l
HS.TyApp () (String -> Length -> Type ()
lengthType String
"FixedArray" Length
l) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeSpecifier -> Maybe (Type ())
specType TypeSpecifier
t
descrType (TypeArray TypeSpecifier
t (VariableLength Length
l)) = forall l. l -> Type l -> Type l -> Type l
HS.TyApp () (String -> Length -> Type ()
lengthType String
"Array" Length
l) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeSpecifier -> Maybe (Type ())
specType TypeSpecifier
t
descrType (TypeOpaque (FixedLength Length
l)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Length -> Type ()
lengthType String
"FixedOpaque" Length
l
descrType (TypeOpaque (VariableLength Length
l)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Length -> Type ()
lengthType String
"Opaque" Length
l
descrType (TypeString (FixedLength Length
l)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Length -> Type ()
lengthType String
"FixedString" Length
l
descrType (TypeString (VariableLength Length
l)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Length -> Type ()
lengthType String
"String" Length
l
descrType (TypeOptional TypeSpecifier
t) = forall l. l -> Type l -> Type l -> Type l
HS.TyApp () (forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
"XDR"String -> String -> QName ()
!String
"Optional") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeSpecifier -> Maybe (Type ())
specType TypeSpecifier
t
declType' :: Declaration -> HS.Type ()
declType' :: Declaration -> Type ()
declType' (Declaration String
n TypeDescriptor
t) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"nested data structures are not supported: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
n) forall a b. (a -> b) -> a -> b
$ TypeDescriptor -> Maybe (Type ())
descrType TypeDescriptor
t
strictType :: HS.Type () -> HS.Type ()
strictType :: Type () -> Type ()
strictType = forall l. l -> BangType l -> Unpackedness l -> Type l -> Type l
HS.TyBang () (forall l. l -> BangType l
HS.BangedTy ()) (forall l. l -> Unpackedness l
HS.NoUnpackPragma ())
declaration :: Declaration -> [HS.FieldDecl ()]
declaration :: Declaration -> [FieldDecl ()]
declaration (Declaration String
_ (TypeSingle (TypeStruct (StructBody [Declaration]
dl)))) =
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [FieldDecl ()]
declaration [Declaration]
dl
declaration d :: Declaration
d@(Declaration String
i TypeDescriptor
_) =
[forall l. l -> [Name l] -> Type l -> FieldDecl l
HS.FieldDecl () [String -> Name ()
HS.name String
i] forall a b. (a -> b) -> a -> b
$ Type () -> Type ()
strictType forall a b. (a -> b) -> a -> b
$ Declaration -> Type ()
declType' Declaration
d]
optionalDeclaration :: OptionalDeclaration -> [HS.FieldDecl ()]
optionalDeclaration :: OptionalDeclaration -> [FieldDecl ()]
optionalDeclaration = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Declaration -> [FieldDecl ()]
declaration
typeDef :: String -> HS.Decl ()
typeDef :: String -> Decl ()
typeDef = Name () -> Name () -> Exp () -> Decl ()
HS.simpleFun (String -> Name ()
HS.name String
"xdrType") (String -> Name ()
HS.name String
"_") forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp ()
HS.strE
fieldNames :: [HS.FieldDecl ()] -> [HS.Name ()]
fieldNames :: [FieldDecl ()] -> [Name ()]
fieldNames = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a -> b) -> a -> b
$ \(HS.FieldDecl ()
_ [Name ()]
nl Type ()
_) -> [Name ()]
nl
putFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp ()
putFields :: Exp () -> [FieldDecl ()] -> Exp ()
putFields Exp ()
_ [] = Exp () -> Exp () -> Exp ()
HS.app (String
"Control.Applicative"String -> String -> Exp ()
!.String
"pure") (forall l. l -> QName l -> Exp l
HS.Con () forall a b. (a -> b) -> a -> b
$ forall l. l -> SpecialCon l -> QName l
HS.Special () forall a b. (a -> b) -> a -> b
$ forall l. l -> SpecialCon l
HS.UnitCon ())
putFields Exp ()
x [FieldDecl ()]
l = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (forall a b c. (a -> b -> c) -> b -> a -> c
flip Exp () -> QOp () -> Exp () -> Exp ()
HS.infixApp forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> QOp l
HS.QVarOp () forall a b. (a -> b) -> a -> b
$ String
"Control.Applicative"String -> String -> QName ()
!String
"*>")
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Exp () -> Exp () -> Exp ()
HS.app (String
"XDR"String -> String -> Exp ()
!.String
"xdrPut") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Exp () -> Exp () -> Exp ()
HS.app Exp ()
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name () -> Exp ()
HS.var)
forall a b. (a -> b) -> a -> b
$ [FieldDecl ()] -> [Name ()]
fieldNames [FieldDecl ()]
l
getFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp ()
getFields :: Exp () -> [FieldDecl ()] -> Exp ()
getFields Exp ()
n = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp ()
c Name ()
_ -> Exp () -> QOp () -> Exp () -> Exp ()
HS.infixApp Exp ()
c (forall l. l -> QName l -> QOp l
HS.QVarOp () forall a b. (a -> b) -> a -> b
$ String
"Control.Applicative"String -> String -> QName ()
!String
"<*>") forall a b. (a -> b) -> a -> b
$ String
"XDR"String -> String -> Exp ()
!.String
"xdrGet") Exp ()
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FieldDecl ()] -> [Name ()]
fieldNames
pureCon :: String -> HS.Exp ()
pureCon :: String -> Exp ()
pureCon = Exp () -> Exp () -> Exp ()
HS.app (String
"Control.Applicative"String -> String -> Exp ()
!.String
"pure") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> QName l -> Exp l
HS.Con () forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
""String -> String -> QName ()
!)
sMatch :: String -> HS.Pat () -> HS.Exp () -> HS.Match ()
sMatch :: String -> Pat () -> Exp () -> Match ()
sMatch String
n Pat ()
p Exp ()
e = forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
HS.Match () (String -> Name ()
HS.name String
n) [Pat ()
p] (forall l. l -> Exp l -> Rhs l
HS.UnGuardedRhs () Exp ()
e) forall a. Maybe a
Nothing
definition :: Definition -> [HS.Decl ()]
definition :: Definition -> [Decl ()]
definition (Definition String
n (TypeDef (TypeSingle (TypeEnum (EnumBody EnumValues
el))))) =
[ String -> [ConDecl ()] -> [String] -> Decl ()
dataDecl String
n
(forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall l. l -> Name l -> [Type l] -> ConDecl l
HS.ConDecl ()) [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name ()
HS.name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) EnumValues
el)
[String
"Eq", String
"Ord", String
"Enum", String
"Bounded", String
"Show"]
, QName () -> String -> [InstDecl ()] -> Decl ()
instDecl (String
"XDR"String -> String -> QName ()
!String
"XDR") String
n forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall l. l -> Decl l -> InstDecl l
HS.InsDecl ())
[ String -> Decl ()
typeDef String
n
, Name () -> Exp () -> Decl ()
HS.nameBind (String -> Name ()
HS.name String
"xdrPut") forall a b. (a -> b) -> a -> b
$ String
"XDR"String -> String -> Exp ()
!.String
"xdrPutEnum"
, Name () -> Exp () -> Decl ()
HS.nameBind (String -> Name ()
HS.name String
"xdrGet") forall a b. (a -> b) -> a -> b
$ String
"XDR"String -> String -> Exp ()
!.String
"xdrGetEnum"
]
, QName () -> String -> [InstDecl ()] -> Decl ()
instDecl (String
"XDR"String -> String -> QName ()
!String
"XDREnum") String
n forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall l. l -> Decl l -> InstDecl l
HS.InsDecl ())
[ forall l. l -> [Match l] -> Decl l
HS.FunBind () forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(String
i,Int
v) ->
String -> Pat () -> Exp () -> Match ()
sMatch String
"xdrFromEnum" (Name () -> [Pat ()] -> Pat ()
HS.pApp (String -> Name ()
HS.name String
i) []) forall a b. (a -> b) -> a -> b
$ Integer -> Exp ()
HS.intE forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Integer
toInteger Int
v)
EnumValues
el
, forall l. l -> [Match l] -> Decl l
HS.FunBind () forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(String
i,Int
v) ->
String -> Pat () -> Exp () -> Match ()
sMatch String
"xdrToEnum" (Integer -> Pat ()
HS.intP forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Integer
toInteger Int
v) forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp ()
HS.app (String
"Prelude"String -> String -> Exp ()
!.String
"return") forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> Exp l
HS.Con () forall a b. (a -> b) -> a -> b
$ String
""String -> String -> QName ()
!String
i)
EnumValues
el forall a. [a] -> [a] -> [a]
++
[ String -> Pat () -> Exp () -> Match ()
sMatch String
"xdrToEnum" (forall l. l -> Pat l
HS.PWildCard ()) forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp ()
HS.app (String
"Prelude"String -> String -> Exp ()
!.String
"fail") forall a b. (a -> b) -> a -> b
$ String -> Exp ()
HS.strE forall a b. (a -> b) -> a -> b
$ String
"invalid " forall a. [a] -> [a] -> [a]
++ String
n]
]
]
definition (Definition String
n (TypeDef (TypeSingle (TypeStruct (StructBody [Declaration]
dl))))) =
[ String -> [ConDecl ()] -> [String] -> Decl ()
dataDecl String
n
[forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
HS.RecDecl () (String -> Name ()
HS.name String
n) [FieldDecl ()]
hdl]
[String
"Eq", String
"Show"]
, QName () -> String -> [InstDecl ()] -> Decl ()
instDecl (String
"XDR"String -> String -> QName ()
!String
"XDR") String
n forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall l. l -> Decl l -> InstDecl l
HS.InsDecl ())
[ String -> Decl ()
typeDef String
n
, Name () -> Name () -> Exp () -> Decl ()
HS.simpleFun (String -> Name ()
HS.name String
"xdrPut") (String -> Name ()
HS.name String
"_x") forall a b. (a -> b) -> a -> b
$ Exp () -> [FieldDecl ()] -> Exp ()
putFields (Name () -> Exp ()
HS.var forall a b. (a -> b) -> a -> b
$ String -> Name ()
HS.name String
"_x") [FieldDecl ()]
hdl
, Name () -> Exp () -> Decl ()
HS.nameBind (String -> Name ()
HS.name String
"xdrGet") forall a b. (a -> b) -> a -> b
$ Exp () -> [FieldDecl ()] -> Exp ()
getFields (String -> Exp ()
pureCon String
n) [FieldDecl ()]
hdl
]
] where
hdl :: [FieldDecl ()]
hdl = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [FieldDecl ()]
declaration [Declaration]
dl
definition (Definition String
n (TypeDef (TypeSingle (TypeUnion (UnionBody d :: Declaration
d@(Declaration String
dn TypeDescriptor
_) [(Int, UnionArm)]
cl Maybe UnionArm
o))))) =
[ String -> [ConDecl ()] -> [String] -> Decl ()
dataDecl String
n
(forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
_,(String
l,[FieldDecl ()]
b)) ->
forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
HS.RecDecl () (String -> Name ()
HS.name String
l) [FieldDecl ()]
b) [(Integer, (String, [FieldDecl ()]))]
hcl
forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(String
l,[FieldDecl ()]
b) -> [forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
HS.RecDecl () (String -> Name ()
HS.name String
l)
forall a b. (a -> b) -> a -> b
$ forall l. l -> [Name l] -> Type l -> FieldDecl l
HS.FieldDecl () [String -> Name ()
HS.name String
hom] (Type () -> Type ()
strictType Type ()
hdt) forall a. a -> [a] -> [a]
: [FieldDecl ()]
b])
Maybe (String, [FieldDecl ()])
ho)
[String
"Eq", String
"Show"]
, forall l. l -> [Name l] -> Type l -> Decl l
HS.TypeSig () [String -> Name ()
HS.name String
dn] forall a b. (a -> b) -> a -> b
$ forall l. l -> Type l -> Type l -> Type l
HS.TyFun () (forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
""String -> String -> QName ()
!String
n) Type ()
hdt
, Name () -> Exp () -> Decl ()
HS.nameBind (String -> Name ()
HS.name String
dn) forall a b. (a -> b) -> a -> b
$ String
"XDR"String -> String -> Exp ()
!.String
"xdrDiscriminant"
, QName () -> String -> [InstDecl ()] -> Decl ()
instDecl (String
"XDR"String -> String -> QName ()
!String
"XDR") String
n forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall l. l -> Decl l -> InstDecl l
HS.InsDecl ())
[ String -> Decl ()
typeDef String
n
, Name () -> Exp () -> Decl ()
HS.nameBind (String -> Name ()
HS.name String
"xdrPut") forall a b. (a -> b) -> a -> b
$ String
"XDR"String -> String -> Exp ()
!.String
"xdrPutUnion"
, Name () -> Exp () -> Decl ()
HS.nameBind (String -> Name ()
HS.name String
"xdrGet") forall a b. (a -> b) -> a -> b
$ String
"XDR"String -> String -> Exp ()
!.String
"xdrGetUnion"
]
, QName () -> String -> [InstDecl ()] -> Decl ()
instDecl (String
"XDR"String -> String -> QName ()
!String
"XDRUnion") String
n
[ forall l. l -> Type l -> Type l -> InstDecl l
HS.InsType () (forall l. l -> Type l -> Type l -> Type l
HS.TyApp () (forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
""String -> String -> QName ()
!String
"XDRDiscriminant") (forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
""String -> String -> QName ()
!String
n)) Type ()
hdt
, forall l. l -> Decl l -> InstDecl l
HS.InsDecl () forall a b. (a -> b) -> a -> b
$ forall l. l -> [Match l] -> Decl l
HS.FunBind () forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
(forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([PatField ()] -> Exp () -> (String, [FieldDecl ()]) -> Match ()
split [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Exp ()
HS.intE))
[(Integer, (String, [FieldDecl ()]))]
hcl
forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ([PatField ()] -> Exp () -> (String, [FieldDecl ()]) -> Match ()
split
[forall l. l -> QName l -> Pat l -> PatField l
HS.PFieldPat () (String
""String -> String -> QName ()
!String
hom) (Name () -> Pat ()
HS.pvar forall a b. (a -> b) -> a -> b
$ String -> Name ()
HS.name String
"d")]
(Exp () -> Exp () -> Exp ()
HS.app (String
"XDR"String -> String -> Exp ()
!.String
"xdrFromEnum") (String
""String -> String -> Exp ()
!.String
"d"))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (String, [FieldDecl ()])
ho)
, forall l. l -> Decl l -> InstDecl l
HS.InsDecl () forall a b. (a -> b) -> a -> b
$ forall l. l -> [Match l] -> Decl l
HS.FunBind () forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
c,(String
l,[FieldDecl ()]
b)) ->
String -> Pat () -> Exp () -> Match ()
sMatch String
"xdrGetUnionArm"
(Integer -> Pat ()
HS.intP Integer
c)
forall a b. (a -> b) -> a -> b
$ Exp () -> [FieldDecl ()] -> Exp ()
getFields (String -> Exp ()
pureCon String
l) [FieldDecl ()]
b)
[(Integer, (String, [FieldDecl ()]))]
hcl
forall a. [a] -> [a] -> [a]
++ [String -> Pat () -> Exp () -> Match ()
sMatch String
"xdrGetUnionArm"
(Name () -> Pat ()
HS.pvar forall a b. (a -> b) -> a -> b
$ String -> Name ()
HS.name String
"_c")
forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Exp () -> Exp () -> Exp ()
HS.app (String
"Prelude"String -> String -> Exp ()
!.String
"fail") forall a b. (a -> b) -> a -> b
$ String -> Exp ()
HS.strE forall a b. (a -> b) -> a -> b
$ String
"invalid " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" discriminant")
(\(String
l,[FieldDecl ()]
b) -> Exp () -> [FieldDecl ()] -> Exp ()
getFields (Exp () -> QOp () -> Exp () -> Exp ()
HS.infixApp (forall l. l -> QName l -> Exp l
HS.Con () forall a b. (a -> b) -> a -> b
$ String
""String -> String -> QName ()
!String
l) (forall l. l -> QName l -> QOp l
HS.QVarOp () forall a b. (a -> b) -> a -> b
$ String
"Control.Applicative"String -> String -> QName ()
!String
"<$>")
(Exp () -> Exp () -> Exp ()
HS.app (String
"XDR"String -> String -> Exp ()
!.String
"xdrToEnum") forall a b. (a -> b) -> a -> b
$ Name () -> Exp ()
HS.var forall a b. (a -> b) -> a -> b
$ String -> Name ()
HS.name String
"_c")) [FieldDecl ()]
b)
Maybe (String, [FieldDecl ()])
ho]
]
] where
split :: [PatField ()] -> Exp () -> (String, [FieldDecl ()]) -> Match ()
split [PatField ()]
p Exp ()
c (String
l,[FieldDecl ()]
b) = String -> Pat () -> Exp () -> Match ()
sMatch String
"xdrSplitUnion"
(forall l. l -> Name l -> Pat l -> Pat l
HS.PAsPat () (String -> Name ()
HS.name String
"_x") forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> [PatField l] -> Pat l
HS.PRec () (String
""String -> String -> QName ()
!String
l) [PatField ()]
p)
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
HS.tuple [Exp ()
c, Exp () -> [FieldDecl ()] -> Exp ()
putFields (String
""String -> String -> Exp ()
!.String
"_x") [FieldDecl ()]
b]
hdt :: Type ()
hdt = Declaration -> Type ()
declType' Declaration
d
hcl :: [(Integer, (String, [FieldDecl ()]))]
hcl = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Integral a => a -> Integer
toInteger forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** UnionArm -> (String, [FieldDecl ()])
arm) [(Int, UnionArm)]
cl
hom :: String
hom = String
dn forall a. [a] -> [a] -> [a]
++ String
"'"
ho :: Maybe (String, [FieldDecl ()])
ho = UnionArm -> (String, [FieldDecl ()])
arm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UnionArm
o
arm :: UnionArm -> (String, [FieldDecl ()])
arm = UnionArm -> String
unionCaseIdentifier forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& OptionalDeclaration -> [FieldDecl ()]
optionalDeclaration forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnionArm -> OptionalDeclaration
unionDeclaration
definition (Definition String
n (TypeDef TypeDescriptor
t)) =
[ forall l. l -> DeclHead l -> Type l -> Decl l
HS.TypeDecl () (forall l. l -> Name l -> DeclHead l
HS.DHead () forall a b. (a -> b) -> a -> b
$ String -> Name ()
HS.name String
n) forall a b. (a -> b) -> a -> b
$ Declaration -> Type ()
declType' (String -> TypeDescriptor -> Declaration
Declaration String
n TypeDescriptor
t)
]
definition (Definition String
n (Constant Integer
v)) =
[ forall l. l -> [Name l] -> Type l -> Decl l
HS.TypeSig () [String -> Name ()
HS.name String
n] Type ()
constantType
, Name () -> Exp () -> Decl ()
HS.nameBind (String -> Name ()
HS.name String
n) forall a b. (a -> b) -> a -> b
$ Integer -> Exp ()
HS.intE Integer
v
]
definition (Definition String
n (Program String
t [Version]
vl Length
px)) =
[ forall l. l -> [Name l] -> Type l -> Decl l
HS.TypeSig () [String -> Name ()
HS.name String
n] forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
""String -> String -> QName ()
!String
t
, Name () -> Exp () -> Decl ()
HS.nameBind (String -> Name ()
HS.name String
n) forall a b. (a -> b) -> a -> b
$ Exp () -> [Exp ()] -> Exp ()
HS.appFun (String
""String -> String -> Exp ()
!.String
t) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Version String
_ String
vt [Procedure]
rl Length
vx) ->
Exp () -> [Exp ()] -> Exp ()
HS.appFun (String
""String -> String -> Exp ()
!.String
vt) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Procedure Maybe TypeSpecifier
_ String
_ [TypeSpecifier]
_ Length
rx) ->
Exp () -> [Exp ()] -> Exp ()
HS.appFun (String
"RPC"String -> String -> Exp ()
!.String
"Procedure") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Exp ()
HS.intE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger) [Length
px, Length
vx, Length
rx])
[Procedure]
rl)
[Version]
vl
, String -> [ConDecl ()] -> [String] -> Decl ()
dataDecl String
t [forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
HS.RecDecl () (String -> Name ()
HS.name String
t) (forall a b. (a -> b) -> [a] -> [b]
map (\(Version String
vn String
vt [Procedure]
_ Length
_) ->
forall l. l -> [Name l] -> Type l -> FieldDecl l
HS.FieldDecl () [String -> Name ()
HS.name String
vn] forall a b. (a -> b) -> a -> b
$ Type () -> Type ()
strictType forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
""String -> String -> QName ()
!String
vt)
[Version]
vl)] []
] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\(Version String
_ String
vt [Procedure]
rl Length
_) ->
String -> [ConDecl ()] -> [String] -> Decl ()
dataDecl String
vt [forall l. l -> Name l -> [FieldDecl l] -> ConDecl l
HS.RecDecl () (String -> Name ()
HS.name String
vt) (forall a b. (a -> b) -> [a] -> [b]
map (\(Procedure Maybe TypeSpecifier
rr String
rn [TypeSpecifier]
ra Length
_) ->
forall l. l -> [Name l] -> Type l -> FieldDecl l
HS.FieldDecl () [String -> Name ()
HS.name String
rn]
forall a b. (a -> b) -> a -> b
$ Type () -> Type ()
strictType forall a b. (a -> b) -> a -> b
$ forall l. l -> Type l -> Type l -> Type l
HS.TyApp () (forall l. l -> Type l -> Type l -> Type l
HS.TyApp () (forall l. l -> QName l -> Type l
HS.TyCon () forall a b. (a -> b) -> a -> b
$ String
"RPC"String -> String -> QName ()
!String
"Procedure")
forall a b. (a -> b) -> a -> b
$ [Type ()] -> Type ()
tt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TypeSpecifier -> Type ()
specType' [TypeSpecifier]
ra)
forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall l. l -> Type l
HS.unit_tycon ()) TypeSpecifier -> Type ()
specType' Maybe TypeSpecifier
rr)
[Procedure]
rl)] []
) [Version]
vl
where
tt :: [Type ()] -> Type ()
tt [] = forall l. l -> Type l
HS.unit_tycon ()
tt [Type ()
a] = Type ()
a
tt [Type ()]
l = forall l. l -> Boxed -> [Type l] -> Type l
HS.TyTuple () Boxed
HS.Boxed [Type ()]
l
hasProgramDefinition :: Specification -> Bool
hasProgramDefinition :: Specification -> Bool
hasProgramDefinition = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Definition -> Bool
isProgramDefinition where
isProgramDefinition :: Definition -> Bool
isProgramDefinition (Definition String
_ Program{}) = Bool
True
isProgramDefinition Definition
_ = Bool
False
specification :: String -> Specification -> HS.Module ()
specification :: String -> Specification -> Module ()
specification String
n Specification
l = forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
HS.Module ()
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l.
l
-> ModuleName l
-> Maybe (WarningText l)
-> Maybe (ExportSpecList l)
-> ModuleHead l
HS.ModuleHead () (forall l. l -> String -> ModuleName l
HS.ModuleName () String
n) forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
[ forall l. l -> [Name l] -> ModulePragma l
HS.LanguagePragma () forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Name ()
HS.name [String
"DataKinds", String
"TypeFamilies"] ]
([forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
HS.ImportDecl () (forall l. l -> String -> ModuleName l
HS.ModuleName () String
"Prelude") Bool
True Bool
False Bool
False forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
, forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
HS.ImportDecl () (forall l. l -> String -> ModuleName l
HS.ModuleName () String
"Control.Applicative") Bool
True Bool
False Bool
False forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
, forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
HS.ImportDecl () (forall l. l -> String -> ModuleName l
HS.ModuleName () String
"Network.ONCRPC.XDR") Bool
True Bool
False Bool
False forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> ModuleName l
HS.ModuleName () String
"XDR") forall a. Maybe a
Nothing
] forall a. [a] -> [a] -> [a]
++ if Specification -> Bool
hasProgramDefinition Specification
l then
[ forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
HS.ImportDecl () (forall l. l -> String -> ModuleName l
HS.ModuleName () String
"Network.ONCRPC.Types") Bool
True Bool
False Bool
False forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> ModuleName l
HS.ModuleName () String
"RPC") forall a. Maybe a
Nothing ]
else [])
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Definition -> [Decl ()]
definition Specification
l
data GenerateOptions = GenerateOptions
{ GenerateOptions -> String
generateModuleName :: String
, GenerateOptions -> ReidentOptions
generateReidentOptions :: ReidentOptions
}
deriving (GenerateOptions -> GenerateOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenerateOptions -> GenerateOptions -> Bool
$c/= :: GenerateOptions -> GenerateOptions -> Bool
== :: GenerateOptions -> GenerateOptions -> Bool
$c== :: GenerateOptions -> GenerateOptions -> Bool
Eq, Int -> GenerateOptions -> ShowS
[GenerateOptions] -> ShowS
GenerateOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenerateOptions] -> ShowS
$cshowList :: [GenerateOptions] -> ShowS
show :: GenerateOptions -> String
$cshow :: GenerateOptions -> String
showsPrec :: Int -> GenerateOptions -> ShowS
$cshowsPrec :: Int -> GenerateOptions -> ShowS
Show)
generateModule :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m (HS.Module ())
generateModule :: forall (m :: * -> *).
MonadFail m =>
GenerateOptions -> String -> ByteString -> m (Module ())
generateModule GenerateOptions{String
ReidentOptions
generateReidentOptions :: ReidentOptions
generateModuleName :: String
generateReidentOptions :: GenerateOptions -> ReidentOptions
generateModuleName :: GenerateOptions -> String
..} String
n ByteString
b = do
(Specification
d, Scope
s) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Either ParseError (Specification, Scope)
XDR.parse String
n ByteString
b
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Specification -> Module ()
specification String
generateModuleName forall a b. (a -> b) -> a -> b
$ ReidentOptions -> Scope -> Specification -> Specification
reident ReidentOptions
generateReidentOptions Scope
s Specification
d
generate :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m String
generate :: forall (m :: * -> *).
MonadFail m =>
GenerateOptions -> String -> ByteString -> m String
generate GenerateOptions
opts String
n ByteString
s = do
Module ()
m <- forall (m :: * -> *).
MonadFail m =>
GenerateOptions -> String -> ByteString -> m (Module ())
generateModule GenerateOptions
opts String
n ByteString
s
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"-- |Generated from " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" by <https://github.com/dylex/oncrpc hsrpcgen>\n"
forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => PPHsMode -> a -> String
prettyPrintWithMode PPHsMode
defaultMode
{ classIndent :: Int
classIndent = Int
2
, doIndent :: Int
doIndent = Int
2
, multiIfIndent :: Int
multiIfIndent = Int
2
, caseIndent :: Int
caseIndent = Int
2
, letIndent :: Int
letIndent = Int
2
, whereIndent :: Int
whereIndent = Int
2
, onsideIndent :: Int
onsideIndent = Int
2
} Module ()
m
generateFromFile :: GenerateOptions -> FilePath -> IO String
generateFromFile :: GenerateOptions -> String -> IO String
generateFromFile GenerateOptions
opts String
f = forall (m :: * -> *).
MonadFail m =>
GenerateOptions -> String -> ByteString -> m String
generate GenerateOptions
opts String
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
BSLC.readFile String
f