-- |Generate Haskell code from XDR descriptions as per RFC4506 and RPC extensions from RFC5531

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

-- |Options for generating Haskell code
data GenerateOptions = GenerateOptions
  { GenerateOptions -> String
generateModuleName :: String -- ^Name for the generated module
  , 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)

-- |Parse an XDR specification and generate a Haskell module, or fail on error.
-- The 'String' argument provides a description of the input to use in parse errors.
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

-- |Parse an XDR specification and generate pretty-printed Haskell source string, or fail on error.
-- The 'String' argument provides a description of the input to use in parse errors.
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

-- |'generate' from a file.
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