Initial commit

bundled/Network/ONCRPC/XDR/Reident.hs

@@ -0,0 +1,108 @@
+-- |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
+