-- | A type model for Haskell datatypes that bears a reasonable correspondence
--   to the XSD type model.
module Text.XML.HaXml.Schema.NameConversion
  ( module Text.XML.HaXml.Schema.NameConversion
  ) where

import Text.XML.HaXml.Types
import Text.XML.HaXml.Namespaces

import Data.Char
import Data.List

-- | An XName just holds the original XSD qualified name.  It does not
--   ensure that the string conforms to any rules of the various Haskell
--   namespaces.  Use a NameConverter to define how you would like names
--   to be mangled.
newtype XName = XName QName
  deriving (XName -> XName -> Bool
(XName -> XName -> Bool) -> (XName -> XName -> Bool) -> Eq XName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XName -> XName -> Bool
$c/= :: XName -> XName -> Bool
== :: XName -> XName -> Bool
$c== :: XName -> XName -> Bool
Eq,Int -> XName -> ShowS
[XName] -> ShowS
XName -> String
(Int -> XName -> ShowS)
-> (XName -> String) -> ([XName] -> ShowS) -> Show XName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XName] -> ShowS
$cshowList :: [XName] -> ShowS
show :: XName -> String
$cshow :: XName -> String
showsPrec :: Int -> XName -> ShowS
$cshowsPrec :: Int -> XName -> ShowS
Show)

-- | An HName is a resolved version of an XName.  It should conform to
--   the various namespace rules, and may already include a module
--   qualifier if appropriate.
newtype HName = HName String
    deriving Int -> HName -> ShowS
[HName] -> ShowS
HName -> String
(Int -> HName -> ShowS)
-> (HName -> String) -> ([HName] -> ShowS) -> Show HName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HName] -> ShowS
$cshowList :: [HName] -> ShowS
show :: HName -> String
$cshow :: HName -> String
showsPrec :: Int -> HName -> ShowS
$cshowsPrec :: Int -> HName -> ShowS
Show

-- | A NameConverter is a collection of functions that convert an XName
--   into an HName, for various Haskell namespaces.  You can define your
--   own arbitrary resolver, but should ensure that you abide by the
--   Haskell rules for conid, varid, etc.
data NameConverter = NameConverter
                       { NameConverter -> XName -> HName
modid    :: XName -> HName
                       , NameConverter -> XName -> HName
conid    :: XName -> HName
                       , NameConverter -> XName -> HName
varid    :: XName -> HName
                       , NameConverter -> XName -> HName
unqconid :: XName -> HName
                       , NameConverter -> XName -> HName
unqvarid :: XName -> HName
                       , NameConverter -> XName -> HName
fwdconid :: XName -> HName  -- ^ for forward type decls
                       , NameConverter -> XName -> XName -> HName
fieldid  :: XName -> XName -> HName
                       }

-- | A simple default set of rules for resolving XNames into HNames.
simpleNameConverter :: NameConverter
simpleNameConverter :: NameConverter
simpleNameConverter = NameConverter :: (XName -> HName)
-> (XName -> HName)
-> (XName -> HName)
-> (XName -> HName)
-> (XName -> HName)
-> (XName -> HName)
-> (XName -> XName -> HName)
-> NameConverter
NameConverter
    { modid :: XName -> HName
modid    = \(XName qn :: QName
qn)-> String -> HName
HName (String -> HName) -> (QName -> String) -> QName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
mkConid ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
hierarchy (QName -> HName) -> QName -> HName
forall a b. (a -> b) -> a -> b
$ QName
qn
    , conid :: XName -> HName
conid    = \(XName qn :: QName
qn)-> String -> HName
HName (String -> HName) -> (QName -> String) -> QName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
mkConid ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
hierarchy (QName -> HName) -> QName -> HName
forall a b. (a -> b) -> a -> b
$ QName
qn
    , varid :: XName -> HName
varid    = \(XName qn :: QName
qn)-> String -> HName
HName (String -> HName) -> (QName -> String) -> QName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
mkVarid ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a. (a -> a) -> [a] -> [a]
last ShowS
avoidKeywords
                                               ([String] -> [String]) -> (QName -> [String]) -> QName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
hierarchy (QName -> HName) -> QName -> HName
forall a b. (a -> b) -> a -> b
$ QName
qn
    , unqconid :: XName -> HName
unqconid = \(XName qn :: QName
qn)-> String -> HName
HName (String -> HName) -> (QName -> String) -> QName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
mkConid ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
local (QName -> HName) -> QName -> HName
forall a b. (a -> b) -> a -> b
$ QName
qn
    , unqvarid :: XName -> HName
unqvarid = \(XName qn :: QName
qn)-> String -> HName
HName (String -> HName) -> (QName -> String) -> QName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
mkVarid ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a. (a -> a) -> [a] -> [a]
last ShowS
avoidKeywords
                                               ([String] -> [String]) -> (QName -> [String]) -> QName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
local (QName -> HName) -> QName -> HName
forall a b. (a -> b) -> a -> b
$ QName
qn
    , fwdconid :: XName -> HName
fwdconid = \(XName qn :: QName
qn)-> String -> HName
HName (String -> HName) -> (QName -> String) -> QName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("Fwd"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (QName -> String) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
mkConid ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
local (QName -> HName) -> QName -> HName
forall a b. (a -> b) -> a -> b
$ QName
qn
    , fieldid :: XName -> XName -> HName
fieldid  = \(XName qnt :: QName
qnt) (XName qnf :: QName
qnf)->
                               String -> HName
HName (String -> HName) -> String -> HName
forall a b. (a -> b) -> a -> b
$ ([String] -> String
mkVarid ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a. (a -> a) -> [a] -> [a]
last ShowS
forall a. a -> a
id ([String] -> [String]) -> (QName -> [String]) -> QName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
hierarchy (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ QName
qnt)
                                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ "_" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                       ([String] -> String
mkVarid ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a. (a -> a) -> [a] -> [a]
last ShowS
forall a. a -> a
id ([String] -> [String]) -> (QName -> [String]) -> QName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
hierarchy (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ QName
qnf)
    }
  where
    hierarchy :: QName -> [String]
hierarchy (N n :: String
n)     = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':') String
n
    hierarchy (QN ns :: Namespace
ns n :: String
n) = [Namespace -> String
nsPrefix Namespace
ns, String
n]

    local :: QName -> [String]
local               = (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (String -> [String]) -> (QName -> String) -> QName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
Prelude.last ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
hierarchy

    mkConid :: [String] -> String
mkConid  []         = "Empty"
    mkConid  [c :: String
c]        | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "string"     = "Xsd.XsdString"
                        | Bool
otherwise = (Char -> Char) -> ShowS
first Char -> Char
toUpper ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
escape String
c
    mkConid [m :: String
m,c :: String
c]       | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "string"     = "Xsd.XsdString"
                        | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "date"       = "Xsd.Date"
                        | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "double"     = "Xsd.Double"
                        | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "integer"    = "Xsd.Integer"
                        | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "boolean"    = "Xsd.Boolean"
                        | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "decimal"    = "Xsd.Decimal"
                        | Bool
otherwise = (Char -> Char) -> ShowS
first Char -> Char
toUpper String
mString -> ShowS
forall a. [a] -> [a] -> [a]
++"."String -> ShowS
forall a. [a] -> [a] -> [a]
++(Char -> Char) -> ShowS
first Char -> Char
toUpper ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
escape String
c)
    mkConid more :: [String]
more        = [String] -> String
mkConid [[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
more]
    mkVarid :: [String] -> String
mkVarid  [v :: String
v]        = (Char -> Char) -> ShowS
first Char -> Char
toLower ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
escape String
v)
    mkVarid [m :: String
m,v :: String
v]       = (Char -> Char) -> ShowS
first Char -> Char
toUpper String
mString -> ShowS
forall a. [a] -> [a] -> [a]
++"."String -> ShowS
forall a. [a] -> [a] -> [a]
++(Char -> Char) -> ShowS
first Char -> Char
toLower ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
escape String
v)

    first :: (Char -> Char) -> ShowS
first f :: Char -> Char
f (x :: Char
x:xs :: String
xs)
      | Bool -> Bool
not (Char -> Bool
isAlpha Char
x) = Char -> Char
f 'v'Char -> ShowS
forall a. a -> [a] -> [a]
: Char
xChar -> ShowS
forall a. a -> [a] -> [a]
: String
xs
      | Bool
otherwise       = Char -> Char
f Char
xChar -> ShowS
forall a. a -> [a] -> [a]
: String
xs
    last :: (a -> a) -> [a] -> [a]
last  f :: a -> a
f [x :: a
x]         = [ a -> a
f a
x ]
    last  f :: a -> a
f (x :: a
x:xs :: [a]
xs)      = a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a) -> [a] -> [a]
last a -> a
f [a]
xs

-- | Character escapes to create a valid Haskell identifier.
escape :: Char -> Char
escape :: Char -> Char
escape x :: Char
x | Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==' '       = '_'
         | Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='_'       = '_'
         | Char -> Bool
isAlphaNum Char
x = Char
x
         | Bool
otherwise    = '\''

 -- cleanUp = map (\c-> if not (isAlphaNum c) then '_' else c)

-- | Ensure that a string does not match a Haskell keyword.
avoidKeywords :: String -> String
avoidKeywords :: ShowS
avoidKeywords s :: String
s
    | String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
keywords  = String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++"_"
    | Bool
otherwise          = String
s
  where
    keywords :: [String]
keywords = [ "case", "of", "data", "default", "deriving", "do"
               , "forall", "foreign", "if", "then", "else", "import"
               , "infix", "infixl", "infixr", "instance", "let", "in"
               , "module", "newtype", "qualified", "type", "where" ]


-- | A specialised module-name converter for FpML module names with
--   multiple dashes, including version numbers,
--   e.g. fpml-dividend-swaps-4-7.xsd      becomes FpML.V47.Swaps.Dividend
--   but  fpml-posttrade-execution-4-7.xsd becomes FpML.V47.PostTrade.Execution
fpml :: String -> String
fpml :: ShowS
fpml = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse "."    -- put the dots in
         ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("Data"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)          -- root of the Haskell module namespace
         ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
rearrange          -- hierarchy shuffling, dependent on names
         ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
cap            -- make into nice module names
         ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
version            -- move version number to front
         ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='-')    -- separate words
         (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
basename ".xsd"    -- strip .xsd if present
  where
    version :: [String] -> [String]
version ws :: [String]
ws = let (last2 :: [String]
last2,remain :: [String]
remain) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt 2 ([String] -> ([String], [String]))
-> ([String] -> [String]) -> [String] -> ([String], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ [String]
ws in
                 if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit) [String]
last2 Bool -> Bool -> Bool
&& [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ws Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 2
                 then [String] -> String
forall a. [a] -> a
head [String]
wsString -> [String] -> [String]
forall a. a -> [a] -> [a]
: ('V'Char -> ShowS
forall a. a -> [a] -> [a]
:[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
last2))
                             String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
remain)
                 else [String]
ws
    rearrange :: [String] -> [String]
rearrange [a :: String
a,v :: String
v,"PostTrade",c :: String
c] = [String
a,String
v,"PostTrade",String
c]
    rearrange [a :: String
a,v :: String
v,b :: String
b,c :: String
c]           = [String
a,String
v,String
c,String
b]
    rearrange [a :: String
a,v :: String
v,b :: String
b,c :: String
c,d :: String
d]         = [String
a,String
v,String
d,String
bString -> ShowS
forall a. [a] -> [a] -> [a]
++String
c]
    rearrange [a :: String
a,v :: String
v,b :: String
b,c :: String
c,d :: String
d,e :: String
e]       = [String
a,String
v,String
e,String
bString -> ShowS
forall a. [a] -> [a] -> [a]
++String
cString -> ShowS
forall a. [a] -> [a] -> [a]
++String
d]
    rearrange v :: [String]
v                   = [String]
v

    cap :: String -> String
    cap :: ShowS
cap "Fpml"      = "FpML"
    cap "fpml"      = "FpML"
    cap "cd"        = "CD"
    cap "eq"        = "EQ"
    cap "fx"        = "FX"
    cap "ird"       = "IRD"
    cap "posttrade" = "PostTrade"
    cap "pretrade"  = "PreTrade"
    cap (c :: Char
c:cs :: String
cs)      = Char -> Char
toUpper Char
cChar -> ShowS
forall a. a -> [a] -> [a]
: String
cs


-- | Chop a list into segments, at separators identified by the predicate.
--   The separator items are discarded.
wordsBy :: (a->Bool) -> [a] -> [[a]]
wordsBy :: (a -> Bool) -> [a] -> [[a]]
wordsBy pred :: a -> Bool
pred = (a -> Bool) -> [a] -> [a] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a] -> [[a]]
wordsBy' a -> Bool
pred []
  where wordsBy' :: (a -> Bool) -> [a] -> [a] -> [[a]]
wordsBy' p :: a -> Bool
p []  []     = []
        wordsBy' p :: a -> Bool
p acc :: [a]
acc []     = [[a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc]
        wordsBy' p :: a -> Bool
p acc :: [a]
acc (c :: a
c:cs :: [a]
cs) | a -> Bool
p a
c       = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:
                                            (a -> Bool) -> [a] -> [a] -> [[a]]
wordsBy' a -> Bool
p [] ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile a -> Bool
p [a]
cs)
                              | Bool
otherwise = (a -> Bool) -> [a] -> [a] -> [[a]]
wordsBy' a -> Bool
p (a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) [a]
cs

-- | Remove any prefix directory names, and given suffix extension.
basename :: String -> String -> String
basename :: String -> ShowS
basename ext :: String
ext = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
snip (ShowS
forall a. [a] -> [a]
reverse String
ext)
                       ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`"\\/")) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse
    where snip :: [a] -> [a] -> [a]
snip p :: [a]
p s :: [a]
s = if [a]
p [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`[a]
s then Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
p) [a]
s else [a]
s

fpmlNameConverter :: NameConverter
fpmlNameConverter :: NameConverter
fpmlNameConverter = NameConverter
simpleNameConverter
    { modid :: XName -> HName
modid   = (\(HName h :: String
h)-> String -> HName
HName (ShowS
fpml String
h))
                (HName -> HName) -> (XName -> HName) -> XName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConverter -> XName -> HName
modid NameConverter
simpleNameConverter
 -- , conid   = (\(HName h)-> case take 4 (reverse h) of
 --                             "munE" -> HName (reverse (drop 4 (reverse h)))
 --                             _      -> HName h )
 --             . conid simpleNameConverter
    , fwdconid :: XName -> HName
fwdconid = \(XName qn :: QName
qn)-> String -> HName
HName (String -> HName) -> (QName -> String) -> QName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("Pseudo"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (QName -> String) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
mkConId ShowS -> (QName -> String) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
local (QName -> HName) -> QName -> HName
forall a b. (a -> b) -> a -> b
$ QName
qn
    , fieldid :: XName -> XName -> HName
fieldid  = \(XName qnt :: QName
qnt) (XName qnf :: QName
qnf)->
                  let t :: String
t = ShowS
mkVarId ShowS -> (QName -> String) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
local (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ QName
qnt
                      f :: String
f = ShowS
mkVarId ShowS -> (QName -> String) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
local (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ QName
qnf
                  in String -> HName
HName (String -> HName) -> String -> HName
forall a b. (a -> b) -> a -> b
$ if String
tString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
f then String
f
                             else ShowS
mkVarId (ShowS
shorten (ShowS
mkConId String
t)) String -> ShowS
forall a. [a] -> [a] -> [a]
++"_"String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                  if String
t String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
f
                                  then ShowS
mkVarId (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t) String
f)
                                  else String
f
    }
  where
    hierarchy :: QName -> [String]
hierarchy (N n :: String
n)     = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':') String
n
    hierarchy (QN ns :: Namespace
ns n :: String
n) = [Namespace -> String
nsPrefix Namespace
ns, String
n]

    local :: QName -> String
local               = [String] -> String
forall a. [a] -> a
Prelude.last ([String] -> String) -> (QName -> [String]) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [String]
hierarchy

    mkVarId :: ShowS
mkVarId   (String
"id")    = "ID"
    mkVarId   (v :: Char
v:vs :: String
vs)    = Char -> Char
toLower Char
vChar -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
escape String
vs
    mkConId :: ShowS
mkConId   (v :: Char
v:vs :: String
vs)    = Char -> Char
toUpper Char
vChar -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
escape String
vs

    shorten :: ShowS
shorten t :: String
t | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 12 = String
t
              | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  35 = ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ShowS
shortenWord (String -> [String]
splitWords String
t)
              | Bool
otherwise      = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> Char
forall a. [a] -> a
head String
tChar -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isUpper (ShowS
forall a. [a] -> [a]
tail String
t))
    splitWords :: String -> [String]
splitWords "" = []
    splitWords (u :: Char
u:s :: String
s)  = let (w :: String
w,rest :: String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\c :: Char
c->Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='_')) String
s
                        in (Char
uChar -> ShowS
forall a. a -> [a] -> [a]
:String
w) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
splitWords String
rest

    shortenWord :: ShowS
shortenWord "Request"     = "Req" -- some special cases
    shortenWord "Reference"   = "Ref"
    shortenWord "Valuation"   = "Val"
    shortenWord "Calendar"    = "Cal"
    shortenWord "Absolute"    = "Abs"
    shortenWord "Additional"  = "Add"
    shortenWord "Business"    = "Bus"
    shortenWord "Standard"    = "Std"
    shortenWord "Calculation" = "Calc"
    shortenWord "Quotation"   = "Quot"
    shortenWord "Information" = "Info"
    shortenWord "Exchange"    = "Exch"
    shortenWord "Characteristics" = "Char"
    shortenWord "Multiple"    = "Multi"
    shortenWord "Constituent" = "Constit"
    shortenWord "Convertible" = "Convert"
    shortenWord "Underlyer"   = "Underly"
    shortenWord "Underlying"  = "Underly"
    shortenWord "Properties"  = "Props"
    shortenWord "Property"    = "Prop"
    shortenWord "Affirmation" = "Affirmation"
    shortenWord "Affirmed"    = "Affirmed"
    shortenWord "KnockIn"     = "KnockIn"  -- avoid shortening
    shortenWord "Knockin"     = "Knockin"
    shortenWord "KnockOut"    = "KnockOut"
    shortenWord "Knockout"    = "Knockout"
    shortenWord w :: String
w | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 8 = String
w   -- then the general rule
                  | Bool
otherwise    = case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt 5 String
w of
                                     (pref :: String
pref,c :: Char
c:suf :: String
suf) | Char -> Bool
isVowel Char
c -> String
pref
                                                  | Bool
otherwise -> String
prefString -> ShowS
forall a. [a] -> [a] -> [a]
++[Char
c]

    isVowel :: Char -> Bool
isVowel = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "aeiouy")