109 lines
4.8 KiB
Haskell
109 lines
4.8 KiB
Haskell
|
-- |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
|
||
|
|
{ reidentUpperPrefix, 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\"@)
|
||
|
|
, reidentJoinField, 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 (Eq, Show)
|
||
|
|
|
||
|
|
defaultReidentOptions :: ReidentOptions
|
||
|
|
defaultReidentOptions = ReidentOptions
|
||
|
|
{ reidentUpperPrefix = ""
|
||
|
|
, reidentLowerPrefix = ""
|
||
|
|
, reidentJoinField = Just "'"
|
||
|
|
, reidentJoinProcedure = Just "'"
|
||
|
|
}
|
||
|
|
|
||
|
|
data ReidentOps = ReidentOps
|
||
|
|
{ reidentUpper, reidentLower :: String -> String
|
||
|
|
, reidentField, reidentProcedure :: String -> String -> String
|
||
|
|
, reidentUnique :: String -> String
|
||
|
|
}
|
||
|
|
|
||
|
|
reidentOps :: ReidentOptions -> XDR.Scope -> ReidentOps
|
||
|
|
reidentOps ReidentOptions{..} scope = ReidentOps
|
||
|
|
{ reidentUpper = toUpperPrefix reidentUpperPrefix
|
||
|
|
, reidentLower = toLowerPrefix reidentLowerPrefix
|
||
|
|
, reidentField = joinField reidentJoinField
|
||
|
|
, reidentProcedure = joinField reidentJoinProcedure
|
||
|
|
, reidentUnique = unique
|
||
|
|
} where
|
||
|
|
toUpperPrefix _ "" = error "empty upper prefix"
|
||
|
|
toUpperPrefix p s@(h:t)
|
||
|
|
| isUpper h = s
|
||
|
|
| null p = toUpper h : t
|
||
|
|
| otherwise = p ++ s
|
||
|
|
toLowerPrefix _ "" = error "empty lower prefix"
|
||
|
|
toLowerPrefix p s@(h:t)
|
||
|
|
| isLower h = s
|
||
|
|
| null p = toLower h : t
|
||
|
|
| otherwise = p ++ s
|
||
|
|
joinField (Just c) p n = p ++ c ++ n
|
||
|
|
joinField Nothing _ n = n
|
||
|
|
unique n
|
||
|
|
| Set.member n dups = n ++ "'"
|
||
|
|
| otherwise = n
|
||
|
|
dups = Map.keysSet $ Map.filter XDR.bindingInitCaseConflict scope
|
||
|
|
|
||
|
|
declaration :: ReidentOps -> String -> Declaration -> Declaration
|
||
|
|
declaration ops n (Declaration m t) = Declaration (reidentLower ops nm) (typeDescriptor ops nm t) where
|
||
|
|
nm = reidentField ops n m
|
||
|
|
|
||
|
|
typeSpecifier :: ReidentOps -> String -> TypeSpecifier -> TypeSpecifier
|
||
|
|
typeSpecifier ops _ (TypeEnum (EnumBody el)) = TypeEnum $
|
||
|
|
EnumBody $ map (first $ reidentUnique ops) el
|
||
|
|
typeSpecifier ops n (TypeStruct (StructBody dl)) = TypeStruct $
|
||
|
|
StructBody $ map (declaration ops n) dl
|
||
|
|
typeSpecifier ops n (TypeUnion (UnionBody d cl o)) = TypeUnion $
|
||
|
|
UnionBody (decl d) (map (second arm) cl) (arm <$> o) where
|
||
|
|
arm (UnionArm l m) = UnionArm (con l) (decl <$> m)
|
||
|
|
con l = reidentUpper ops $ n ++ '\'' : l
|
||
|
|
decl = declaration ops n
|
||
|
|
typeSpecifier ops _ (TypeIdentifier i) = TypeIdentifier $
|
||
|
|
reidentUpper ops $ reidentUnique ops i
|
||
|
|
typeSpecifier _ _ t = t
|
||
|
|
|
||
|
|
typeDescriptor :: ReidentOps -> String -> TypeDescriptor -> TypeDescriptor
|
||
|
|
typeDescriptor ops n (TypeSingle t) = TypeSingle (typeSpecifier ops n t)
|
||
|
|
typeDescriptor ops n (TypeArray t l) = TypeArray (typeSpecifier ops n t) l
|
||
|
|
typeDescriptor ops n (TypeOptional t) = TypeOptional (typeSpecifier ops n t)
|
||
|
|
typeDescriptor _ _ t = t
|
||
|
|
|
||
|
|
procedure :: ReidentOps -> String -> Procedure -> Procedure
|
||
|
|
procedure ops n (Procedure r m al x) = Procedure (ts <$> r) (reidentLower ops nm) (ts <$> al) x where
|
||
|
|
nm = reidentProcedure ops n m
|
||
|
|
ts = typeSpecifier ops nm
|
||
|
|
|
||
|
|
version :: ReidentOps -> String -> Version -> Version
|
||
|
|
version ops n (Version m t pl x) = Version (reidentLower ops nm) (reidentUpper ops nt) (map (procedure ops nm) pl) x where
|
||
|
|
nm = reidentProcedure ops n m
|
||
|
|
nt = reidentProcedure ops n t
|
||
|
|
|
||
|
|
makeDefinition :: ReidentOps -> String -> DefinitionBody -> Definition
|
||
|
|
makeDefinition ops n (TypeDef d) = Definition (reidentUpper ops n) $ TypeDef $ typeDescriptor ops n d
|
||
|
|
makeDefinition ops n (Program t vl x) = Definition (reidentLower ops n) $ Program (reidentUpper ops t) (map (version ops n) vl) x
|
||
|
|
makeDefinition ops n b@(Constant _) = Definition (reidentLower ops n) b
|
||
|
|
|
||
|
|
definition :: ReidentOps -> Definition -> Definition
|
||
|
|
definition ops (Definition n d) = makeDefinition ops (reidentUnique ops n) d
|
||
|
|
|
||
|
|
reident :: ReidentOptions -> XDR.Scope -> Specification -> Specification
|
||
|
|
reident o = map . definition . reidentOps o
|
||
|
|
|