-- |Convert XDR identifiers to Haskell identifiers.
-- Rules to convert identifiers in a 'Specification' to follow Haskell's lexical rules and ensure uniqueness for Haskell's scoping.
{-# LANGUAGE RecordWildCards #-}
module Network.ONCRPC.XDR.Reident
  ( ReidentOptions(..)
  , defaultReidentOptions
  , reident
  ) where

import           Control.Arrow (first, second)
import           Data.Char (isLower, isUpper, toLower, toUpper)
import qualified Data.Map as Map
import qualified Data.Set as Set

import           Network.ONCRPC.XDR.Specification
import qualified Network.ONCRPC.XDR.Parse as XDR

-- |How to generate Haskell identifiers from XDR in order to confirm to Haskell's lexical rules and ensure uniqueness.
data ReidentOptions = ReidentOptions
  { ReidentOptions -> String
reidentUpperPrefix, ReidentOptions -> String
reidentLowerPrefix :: String -- ^Prefix to use to make an identifier a different case if necessary, e.g. @\"_\"@ for lower-case, or @\"XDR_\"@ for upper case (default empty: just changes the first character, possibly resulting in names like @\"nFS_NULL\"@)
  , ReidentOptions -> Maybe String
reidentJoinField, ReidentOptions -> Maybe String
reidentJoinProcedure :: Maybe String -- ^Prefix fields with their type name (or program, version name) and this string (necessary for most XDR files), or @Nothing@ to use only the field name (or procedure name), which assumes uniqueness across the file (e.g., if you wrote the file yourself, though often safe for procedures only) (default @Just \"\'\"@)
  }
  deriving (ReidentOptions -> ReidentOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReidentOptions -> ReidentOptions -> Bool
$c/= :: ReidentOptions -> ReidentOptions -> Bool
== :: ReidentOptions -> ReidentOptions -> Bool
$c== :: ReidentOptions -> ReidentOptions -> Bool
Eq, Int -> ReidentOptions -> ShowS
[ReidentOptions] -> ShowS
ReidentOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReidentOptions] -> ShowS
$cshowList :: [ReidentOptions] -> ShowS
show :: ReidentOptions -> String
$cshow :: ReidentOptions -> String
showsPrec :: Int -> ReidentOptions -> ShowS
$cshowsPrec :: Int -> ReidentOptions -> ShowS
Show)

defaultReidentOptions :: ReidentOptions
defaultReidentOptions :: ReidentOptions
defaultReidentOptions = ReidentOptions
  { reidentUpperPrefix :: String
reidentUpperPrefix = String
""
  , reidentLowerPrefix :: String
reidentLowerPrefix = String
""
  , reidentJoinField :: Maybe String
reidentJoinField = forall a. a -> Maybe a
Just String
"'"
  , reidentJoinProcedure :: Maybe String
reidentJoinProcedure = forall a. a -> Maybe a
Just String
"'"
  }

data ReidentOps = ReidentOps
  { ReidentOps -> ShowS
reidentUpper, ReidentOps -> ShowS
reidentLower :: String -> String
  , ReidentOps -> String -> ShowS
reidentField, ReidentOps -> String -> ShowS
reidentProcedure :: String -> String -> String
  , ReidentOps -> ShowS
reidentUnique :: String -> String
  }

reidentOps :: ReidentOptions -> XDR.Scope -> ReidentOps
reidentOps :: ReidentOptions -> Scope -> ReidentOps
reidentOps ReidentOptions{String
Maybe String
reidentJoinProcedure :: Maybe String
reidentJoinField :: Maybe String
reidentLowerPrefix :: String
reidentUpperPrefix :: String
reidentJoinProcedure :: ReidentOptions -> Maybe String
reidentJoinField :: ReidentOptions -> Maybe String
reidentLowerPrefix :: ReidentOptions -> String
reidentUpperPrefix :: ReidentOptions -> String
..} Scope
scope = ReidentOps
  { reidentUpper :: ShowS
reidentUpper = String -> ShowS
toUpperPrefix String
reidentUpperPrefix
  , reidentLower :: ShowS
reidentLower = String -> ShowS
toLowerPrefix String
reidentLowerPrefix
  , reidentField :: String -> ShowS
reidentField = forall {a}. Maybe [a] -> [a] -> [a] -> [a]
joinField Maybe String
reidentJoinField
  , reidentProcedure :: String -> ShowS
reidentProcedure = forall {a}. Maybe [a] -> [a] -> [a] -> [a]
joinField Maybe String
reidentJoinProcedure
  , reidentUnique :: ShowS
reidentUnique = ShowS
unique
  } where
  toUpperPrefix :: String -> ShowS
toUpperPrefix String
p s :: String
s@(~(Char
h:String
t))
    | Char -> Bool
isUpper Char
h = String
s
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p = Char -> Char
toUpper Char
h forall a. a -> [a] -> [a]
: String
t
    | Bool
otherwise = String
p forall a. [a] -> [a] -> [a]
++ String
s
  toLowerPrefix :: String -> ShowS
toLowerPrefix String
p s :: String
s@(~(Char
h:String
t))
    | Char -> Bool
isLower Char
h = String
s
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p = Char -> Char
toLower Char
h forall a. a -> [a] -> [a]
: String
t
    | Bool
otherwise = String
p forall a. [a] -> [a] -> [a]
++ String
s
  joinField :: Maybe [a] -> [a] -> [a] -> [a]
joinField (Just [a]
c) [a]
p [a]
n = [a]
p forall a. [a] -> [a] -> [a]
++ [a]
c forall a. [a] -> [a] -> [a]
++ [a]
n
  joinField Maybe [a]
Nothing [a]
_ [a]
n = [a]
n
  unique :: ShowS
unique String
n
    | forall a. Ord a => a -> Set a -> Bool
Set.member String
n Set String
dups = String
n forall a. [a] -> [a] -> [a]
++ String
"'"
    | Bool
otherwise = String
n
  dups :: Set String
dups = forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Binding -> Bool
XDR.bindingInitCaseConflict Scope
scope

declaration :: ReidentOps -> String -> Declaration -> Declaration
declaration :: ReidentOps -> String -> Declaration -> Declaration
declaration ReidentOps
ops String
n (Declaration String
m TypeDescriptor
t) = String -> TypeDescriptor -> Declaration
Declaration (ReidentOps -> ShowS
reidentLower ReidentOps
ops String
nm) (ReidentOps -> String -> TypeDescriptor -> TypeDescriptor
typeDescriptor ReidentOps
ops String
nm TypeDescriptor
t) where
  nm :: String
nm = ReidentOps -> String -> ShowS
reidentField ReidentOps
ops String
n String
m

typeSpecifier :: ReidentOps -> String -> TypeSpecifier -> TypeSpecifier
typeSpecifier :: ReidentOps -> String -> TypeSpecifier -> TypeSpecifier
typeSpecifier ReidentOps
ops String
_ (TypeEnum (EnumBody EnumValues
el)) = EnumBody -> TypeSpecifier
TypeEnum forall a b. (a -> b) -> a -> b
$ 
  EnumValues -> EnumBody
EnumBody forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ ReidentOps -> ShowS
reidentUnique ReidentOps
ops) EnumValues
el
typeSpecifier ReidentOps
ops String
n (TypeStruct (StructBody [Declaration]
dl)) = StructBody -> TypeSpecifier
TypeStruct forall a b. (a -> b) -> a -> b
$ 
  [Declaration] -> StructBody
StructBody forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ReidentOps -> String -> Declaration -> Declaration
declaration ReidentOps
ops String
n) [Declaration]
dl
typeSpecifier ReidentOps
ops String
n (TypeUnion (UnionBody Declaration
d [(Int, UnionArm)]
cl Maybe UnionArm
o)) = UnionBody -> TypeSpecifier
TypeUnion forall a b. (a -> b) -> a -> b
$
  Declaration -> [(Int, UnionArm)] -> Maybe UnionArm -> UnionBody
UnionBody (Declaration -> Declaration
decl Declaration
d) (forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second UnionArm -> UnionArm
arm) [(Int, UnionArm)]
cl) (UnionArm -> UnionArm
arm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UnionArm
o) where
  arm :: UnionArm -> UnionArm
arm (UnionArm String
l OptionalDeclaration
m) = String -> OptionalDeclaration -> UnionArm
UnionArm (ShowS
con String
l) (Declaration -> Declaration
decl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionalDeclaration
m)
  con :: ShowS
con String
l = ReidentOps -> ShowS
reidentUpper ReidentOps
ops forall a b. (a -> b) -> a -> b
$ String
n forall a. [a] -> [a] -> [a]
++ Char
'\'' forall a. a -> [a] -> [a]
: String
l
  decl :: Declaration -> Declaration
decl = ReidentOps -> String -> Declaration -> Declaration
declaration ReidentOps
ops String
n
typeSpecifier ReidentOps
ops String
_ (TypeIdentifier String
i) = String -> TypeSpecifier
TypeIdentifier forall a b. (a -> b) -> a -> b
$
  ReidentOps -> ShowS
reidentUpper ReidentOps
ops forall a b. (a -> b) -> a -> b
$ ReidentOps -> ShowS
reidentUnique ReidentOps
ops String
i
typeSpecifier ReidentOps
_ String
_ TypeSpecifier
t = TypeSpecifier
t

typeDescriptor :: ReidentOps -> String -> TypeDescriptor -> TypeDescriptor
typeDescriptor :: ReidentOps -> String -> TypeDescriptor -> TypeDescriptor
typeDescriptor ReidentOps
ops String
n (TypeSingle TypeSpecifier
t) = TypeSpecifier -> TypeDescriptor
TypeSingle (ReidentOps -> String -> TypeSpecifier -> TypeSpecifier
typeSpecifier ReidentOps
ops String
n TypeSpecifier
t)
typeDescriptor ReidentOps
ops String
n (TypeArray TypeSpecifier
t ArrayLength
l) = TypeSpecifier -> ArrayLength -> TypeDescriptor
TypeArray (ReidentOps -> String -> TypeSpecifier -> TypeSpecifier
typeSpecifier ReidentOps
ops String
n TypeSpecifier
t) ArrayLength
l
typeDescriptor ReidentOps
ops String
n (TypeOptional TypeSpecifier
t) = TypeSpecifier -> TypeDescriptor
TypeOptional (ReidentOps -> String -> TypeSpecifier -> TypeSpecifier
typeSpecifier ReidentOps
ops String
n TypeSpecifier
t)
typeDescriptor ReidentOps
_ String
_ TypeDescriptor
t = TypeDescriptor
t

procedure :: ReidentOps -> String -> Procedure -> Procedure
procedure :: ReidentOps -> String -> Procedure -> Procedure
procedure ReidentOps
ops String
n (Procedure Maybe TypeSpecifier
r String
m [TypeSpecifier]
al ProcNum
x) = Maybe TypeSpecifier
-> String -> [TypeSpecifier] -> ProcNum -> Procedure
Procedure (TypeSpecifier -> TypeSpecifier
ts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TypeSpecifier
r) (ReidentOps -> ShowS
reidentLower ReidentOps
ops String
nm) (TypeSpecifier -> TypeSpecifier
ts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeSpecifier]
al) ProcNum
x where
  nm :: String
nm = ReidentOps -> String -> ShowS
reidentProcedure ReidentOps
ops String
n String
m
  ts :: TypeSpecifier -> TypeSpecifier
ts = ReidentOps -> String -> TypeSpecifier -> TypeSpecifier
typeSpecifier ReidentOps
ops String
nm

version :: ReidentOps -> String -> Version -> Version
version :: ReidentOps -> String -> Version -> Version
version ReidentOps
ops String
n (Version String
m String
t [Procedure]
pl ProcNum
x) = String -> String -> [Procedure] -> ProcNum -> Version
Version (ReidentOps -> ShowS
reidentLower ReidentOps
ops String
nm) (ReidentOps -> ShowS
reidentUpper ReidentOps
ops String
nt) (forall a b. (a -> b) -> [a] -> [b]
map (ReidentOps -> String -> Procedure -> Procedure
procedure ReidentOps
ops String
nm) [Procedure]
pl) ProcNum
x where
  nm :: String
nm = ReidentOps -> String -> ShowS
reidentProcedure ReidentOps
ops String
n String
m
  nt :: String
nt = ReidentOps -> String -> ShowS
reidentProcedure ReidentOps
ops String
n String
t

makeDefinition :: ReidentOps -> String -> DefinitionBody -> Definition
makeDefinition :: ReidentOps -> String -> DefinitionBody -> Definition
makeDefinition ReidentOps
ops String
n (TypeDef TypeDescriptor
d) = String -> DefinitionBody -> Definition
Definition (ReidentOps -> ShowS
reidentUpper ReidentOps
ops String
n) forall a b. (a -> b) -> a -> b
$ TypeDescriptor -> DefinitionBody
TypeDef forall a b. (a -> b) -> a -> b
$ ReidentOps -> String -> TypeDescriptor -> TypeDescriptor
typeDescriptor ReidentOps
ops String
n TypeDescriptor
d
makeDefinition ReidentOps
ops String
n (Program String
t [Version]
vl ProcNum
x) = String -> DefinitionBody -> Definition
Definition (ReidentOps -> ShowS
reidentLower ReidentOps
ops String
n) forall a b. (a -> b) -> a -> b
$ String -> [Version] -> ProcNum -> DefinitionBody
Program (ReidentOps -> ShowS
reidentUpper ReidentOps
ops String
t) (forall a b. (a -> b) -> [a] -> [b]
map (ReidentOps -> String -> Version -> Version
version ReidentOps
ops String
n) [Version]
vl) ProcNum
x
makeDefinition ReidentOps
ops String
n b :: DefinitionBody
b@(Constant Integer
_) = String -> DefinitionBody -> Definition
Definition (ReidentOps -> ShowS
reidentLower ReidentOps
ops String
n) DefinitionBody
b

definition :: ReidentOps -> Definition -> Definition
definition :: ReidentOps -> Definition -> Definition
definition ReidentOps
ops (Definition String
n DefinitionBody
d) = ReidentOps -> String -> DefinitionBody -> Definition
makeDefinition ReidentOps
ops (ReidentOps -> ShowS
reidentUnique ReidentOps
ops String
n) DefinitionBody
d

reident :: ReidentOptions -> XDR.Scope -> Specification -> Specification
reident :: ReidentOptions -> Scope -> Specification -> Specification
reident ReidentOptions
o = forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReidentOps -> Definition -> Definition
definition forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReidentOptions -> Scope -> ReidentOps
reidentOps ReidentOptions
o