-- | 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 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 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 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 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 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 QName
qn)-> String -> HName
HName (String -> HName) -> (QName -> String) -> QName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"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 QName
qnt) (XName 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
"_" 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 String
n)     = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') String
n
    hierarchy (QN Namespace
ns 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  []         = String
"Empty"
    mkConid  [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
"string"     = 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 [String
m,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
"string"     = 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
== String
"date"       = String
"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
== String
"double"     = String
"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
== String
"integer"    = String
"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
== String
"boolean"    = String
"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
== String
"decimal"    = String
"Xsd.Decimal"
                        | Bool
otherwise = (Char -> Char) -> ShowS
first Char -> Char
toUpper String
mString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"."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 [String]
more        = [String] -> String
mkConid [[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
more]
    mkVarid :: [String] -> String
mkVarid  [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 [String
m,String
v]       = (Char -> Char) -> ShowS
first Char -> Char
toUpper String
mString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"."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 Char -> Char
f (Char
x:String
xs)
      | Bool -> Bool
not (Char -> Bool
isAlpha Char
x) = Char -> Char
f Char
'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  a -> a
f [a
x]         = [ a -> a
f a
x ]
    last  a -> a
f (a
x:[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 Char
x | Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' '       = Char
'_'
         | Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_'       = Char
'_'
         | Char -> Bool
isAlphaNum Char
x = Char
x
         | Bool
otherwise    = Char
'\''

 -- 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 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]
++String
"_"
    | Bool
otherwise          = String
s
  where
    keywords :: [String]
keywords = [ String
"case", String
"of", String
"data", String
"default", String
"deriving", String
"do"
               , String
"forall", String
"foreign", String
"if", String
"then", String
"else", String
"import"
               , String
"infix", String
"infixl", String
"infixr", String
"instance", String
"let", String
"in"
               , String
"module", String
"newtype", String
"qualified", String
"type", String
"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] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"."        -- put the dots in
         ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"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
==Char
'-')    -- separate words
         (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
basename String
".xsd"    -- strip .xsd if present
  where
    version :: [String] -> [String]
version [String]
ws = let ([String]
last2,[String]
remain) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
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
> Int
2
                 then [String] -> String
forall a. [a] -> a
head [String]
wsString -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char
'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 [String
a,String
v,String
"PostTrade",String
c] = [String
a,String
v,String
"PostTrade",String
c]
    rearrange [String
a,String
v,String
b,String
c]           = [String
a,String
v,String
c,String
b]
    rearrange [String
a,String
v,String
b,String
c,String
d]         = [String
a,String
v,String
d,String
bString -> ShowS
forall a. [a] -> [a] -> [a]
++String
c]
    rearrange [String
a,String
v,String
b,String
c,String
d,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 [String]
v                   = [String]
v

    cap :: String -> String
    cap :: ShowS
cap String
"Fpml"      = String
"FpML"
    cap String
"fpml"      = String
"FpML"
    cap String
"cd"        = String
"CD"
    cap String
"eq"        = String
"EQ"
    cap String
"fx"        = String
"FX"
    cap String
"ird"       = String
"IRD"
    cap String
"posttrade" = String
"PostTrade"
    cap String
"pretrade"  = String
"PreTrade"
    cap (Char
c: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 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' a -> Bool
p []  []     = []
        wordsBy' a -> Bool
p [a]
acc []     = [[a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc]
        wordsBy' a -> Bool
p [a]
acc (a
c:[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 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`String
"\\/")) 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 [a]
p [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 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 QName
qn)-> String -> HName
HName (String -> HName) -> (QName -> String) -> QName -> HName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"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 QName
qnt) (XName 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
"_"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 String
n)     = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') String
n
    hierarchy (QN Namespace
ns 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"      = String
"ID"
    mkVarId   (Char
v: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   (Char
v: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 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
<= Int
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
<  Int
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 String
"" = []
    splitWords (Char
u:String
s)  = let (String
w,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\Char
c->Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_') 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 String
"Request"     = String
"Req" -- some special cases
    shortenWord String
"Reference"   = String
"Ref"
    shortenWord String
"Valuation"   = String
"Val"
    shortenWord String
"Calendar"    = String
"Cal"
    shortenWord String
"Absolute"    = String
"Abs"
    shortenWord String
"Additional"  = String
"Add"
    shortenWord String
"Business"    = String
"Bus"
    shortenWord String
"Standard"    = String
"Std"
    shortenWord String
"Calculation" = String
"Calc"
    shortenWord String
"Quotation"   = String
"Quot"
    shortenWord String
"Information" = String
"Info"
    shortenWord String
"Exchange"    = String
"Exch"
    shortenWord String
"Characteristics" = String
"Char"
    shortenWord String
"Multiple"    = String
"Multi"
    shortenWord String
"Constituent" = String
"Constit"
    shortenWord String
"Convertible" = String
"Convert"
    shortenWord String
"Underlyer"   = String
"Underly"
    shortenWord String
"Underlying"  = String
"Underly"
    shortenWord String
"Properties"  = String
"Props"
    shortenWord String
"Property"    = String
"Prop"
    shortenWord String
"Affirmation" = String
"Affirmation"
    shortenWord String
"Affirmed"    = String
"Affirmed"
    shortenWord String
"KnockIn"     = String
"KnockIn"  -- avoid shortening
    shortenWord String
"Knockin"     = String
"Knockin"
    shortenWord String
"KnockOut"    = String
"KnockOut"
    shortenWord String
"Knockout"    = String
"Knockout"
    shortenWord 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
< Int
8 = String
w   -- then the general rule
                  | Bool
otherwise    = case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
5 String
w of
                                     (String
pref,Char
c: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` String
"aeiouy")