json-spec-openapi-1.0.0.0: src/Data/JsonSpec/OpenApi/Rename.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.JsonSpec.OpenApi.Rename (
Rename
) where
import Data.JsonSpec
( FieldSpec(Optional, Required)
, Specification
( JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet
, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag
)
)
import GHC.TypeError (ErrorMessage((:$$:)))
import GHC.TypeLits (type (+), AppendSymbol, Nat, Symbol)
import qualified GHC.TypeError as TE
{-|
Resolve OpenApi name conflicts.
The json-spec mechanism for giving names to things is more powerful than
OpenApi mechanism for naming things. 'JsonLet' allows for nested scopes,
where deeper names can shadow other names. OpenApi on the other hand only has
a flat space to name schemas, so every name is "globally scoped", resulting
in possible name conflicts when mapping 'JsonLet' names to OpenApi names.
This type family resolves the conflict by renaming the 'JsonLet' names
in your 'Specification' so that they are all unique, so they won't
conflict when mapping them into the global OpenApi schema namespace.
We do not apply this type family by default because it has the potential to
add significant compilation time if your 'Specification's are large. If you
happen to know that your 'Specification' contains no name conflicts then you
can avoid paying that cost.
It isn't perfect. I've tried to strike a balance between implementation
complexity and avoiding unnecessary renames.
Essentially, if a duplicate name is detected, I append a @".<n>"@ to the
name, where @<n>@ is an integer. So if you are using names that /already/
follow this format you might get into trouble.
For instance, this 'Specification' will fail to rename properly:
> JsonLet
> '[ '("foo", JsonString)
> , '("foo.1", JsonString)
> ]
> ( JsonObject
> '[ "field1" ::: JsonRef "foo"
> , "field2" ::: JsonLet '[ '("foo", JsonInt)] (JsonRef "foo")
> ]
> )
because the "foo" in "field2" will be renamed to "foo.1", causing a
new conflict with the existing "foo.1".
-}
type family Rename (spec :: Specification) :: Specification where
Rename spec =
Fst (FoldRename (G '[]) (A '[]) spec)
type family
Fst
(a :: (Specification, Global))
:: Specification
where
Fst '(spec, global) = spec
type family
FoldRename
(global :: Global)
(active :: Active)
(spec :: Specification)
:: (Specification, Global)
where
FoldRename global active JsonString = '(JsonString, global)
FoldRename global active JsonNum = '(JsonNum, global)
FoldRename global active JsonInt = '(JsonInt, global)
FoldRename global active JsonBool = '(JsonBool, global)
FoldRename global active (JsonTag tag) = '(JsonTag tag, global)
FoldRename global active JsonDateTime = '(JsonDateTime, global)
FoldRename global active JsonRaw = '(JsonRaw, global)
FoldRename global active (JsonNullable spec) =
MapSpec
JsonNullable
(FoldRename global active spec)
FoldRename global active (JsonArray spec) =
MapSpec JsonArray (FoldRename global active spec)
FoldRename global active (JsonObject fields) =
RenameObject global active fields
FoldRename global active (JsonEither left right) =
RenameEither global active left right
FoldRename global active (JsonLet defs spec) =
RenameLet
(UpdateGlobals global defs)
active
defs
spec
FoldRename global (A active) (JsonRef name) =
'(JsonRef (LookupNewName name active), global)
type family
RenameObject
(global :: Global)
(active :: Active)
(fields :: [FieldSpec])
:: (Specification, Global)
where
RenameObject global active fields =
RenameObject2
(FoldReflectFields '( '[], global) active fields)
type family
RenameObject2
(acc :: ([FieldSpec], Global))
:: (Specification, Global)
where
RenameObject2 '(fields, global) =
'(JsonObject (Reverse '[] fields), global)
type family
FoldReflectFields
( acc :: ([FieldSpec], Global))
(active :: Active)
(fields :: [FieldSpec])
:: ([FieldSpec], Global)
where
FoldReflectFields '(acc, global) active '[] = '(acc, global)
FoldReflectFields '(acc, global) active (field : more) =
FoldReflectFields2
acc
active
(ReflectField global active field)
more
type family
FoldReflectFields2
( acc :: [FieldSpec])
(active :: Active)
( field :: (FieldSpec, Global))
( more :: [FieldSpec])
:: ([FieldSpec], Global)
where
FoldReflectFields2 acc active '(field, global) more =
FoldReflectFields
'(field : acc, global)
active
more
type family
ReflectField
(global :: Global)
(active :: Active)
(field :: FieldSpec)
:: (FieldSpec, Global)
where
ReflectField global active (Required name spec) =
ReflectRequiredField
name
(FoldRename global active spec)
ReflectField global active (Optional name spec) =
ReflectOptionalField
name
(FoldRename global active spec)
type family
ReflectRequiredField
(name :: Symbol)
(spec :: (Specification, Global))
:: (FieldSpec, Global)
where
ReflectRequiredField name '(spec, global) =
'(Required name spec, global)
type family
ReflectOptionalField
(name :: Symbol)
(spec :: (Specification, Global))
:: (FieldSpec, Global)
where
ReflectOptionalField name '(spec, global) =
'(Optional name spec, global)
type family
RenameEither
(global :: Global)
(active :: Active)
( left :: Specification)
( right :: Specification)
:: (Specification, Global)
where
RenameEither global active left right =
RenameEither2
active
(FoldRename global active left)
right
type family
RenameEither2
(active :: Active)
( left :: (Specification, Global))
( right :: Specification)
:: (Specification, Global)
where
RenameEither2 active '(left, global) right =
RenameEither3 left (FoldRename global active right)
type family
RenameEither3
(left :: Specification)
(right :: (Specification, Global))
:: (Specification, Global)
where
RenameEither3 left '(right, global) =
'(JsonEither left right, global)
type family
UpdateGlobals
(global :: Global)
( defs :: [(Symbol, Specification)])
:: Global
where
UpdateGlobals global '[] = global
UpdateGlobals (G global) ( '(name, spec) : more) =
UpdateGlobals
(G (IncrementName global name))
more
type family
IncrementName
(global :: [NameState])
( name :: Symbol)
:: [NameState]
where
IncrementName '[] name = '[N name 0]
IncrementName (N name ord : more) name =
N name (ord + 1) : more
IncrementName (N miss ord : more) name =
N miss ord : IncrementName more name
type family
RenameLet
(global :: Global) -- updated
(active :: Active)
(defs :: [(Symbol, Specification)])
(spec :: Specification)
:: (Specification, Global)
where
RenameLet global active defs spec =
RenameLet2
global
(UpdateActives global active defs)
defs
spec
type family
RenameLet2
(global :: Global) -- updated
(active :: Active) -- updated
(defs :: [(Symbol, Specification)])
(spec :: Specification)
where
RenameLet2 global active defs spec =
RenameLet3
global
active
(RenameDefs global defs)
spec
type family
RenameLet3
(global :: Global)
(active :: Active)
( defs :: [(Symbol, Specification)])
( spec :: Specification)
:: (Specification, Global)
where
RenameLet3 global active defs spec =
RenameLet4
(ReflectDefs global active defs)
active
spec
type family
RenameLet4
( r :: (Global, [(Symbol, Specification)]))
(active :: Active)
( spec :: Specification)
:: (Specification, Global)
where
RenameLet4 '(global, defs) active spec =
RenameLet5
(FoldRename global active spec)
defs
type family
RenameLet5
(r :: (Specification, Global))
(defs :: [(Symbol, Specification)])
:: (Specification, Global)
where
RenameLet5 '(spec, global) defs =
'(JsonLet defs spec, global)
type family
UpdateActives
(global :: Global) -- already updated
(active :: Active)
( defs :: [(Symbol, Specification)])
:: Active
where
UpdateActives global active '[] = active
UpdateActives global (A active) ( '(name, spec) : more) =
UpdateActives
global
(A (SetActive global active name))
more
type family
SetActive
(global :: Global)
(active :: [NameState])
( name :: Symbol)
:: [NameState]
where
SetActive
(G (N name ord : moreG))
(N name x : moreA)
name
=
(N name ord : moreA)
SetActive
(G (N name ord : moreG))
(N miss x : moreA)
name
=
N miss x : SetActive (G (N name ord : moreG)) moreA name
SetActive
(G (N name ord : moreG))
'[]
name
=
'[N name ord]
SetActive
(G (N miss x : moreG))
active
name
=
SetActive (G moreG) active name
type family
ReflectDefs
(global :: Global)
(active :: Active)
( defs :: [(Symbol, Specification)])
:: (Global, [(Symbol, Specification)])
where
ReflectDefs global active defs =
FoldReflectDefs '(global, '[]) active defs
type family
FoldReflectDefs
(acc :: (Global, [(Symbol, Specification)]))
(active :: Active)
(defs :: [(Symbol, Specification)])
:: (Global, [(Symbol, Specification)])
where
FoldReflectDefs acc active '[] = acc
FoldReflectDefs
'(global, acc)
active
( '(name, spec) : more )
=
FoldReflectDefs2
(FoldRename global active spec)
active
name
acc
more
type family
FoldReflectDefs2
( spec :: (Specification, Global))
(active :: Active)
( name :: Symbol)
( acc :: [(Symbol, Specification)])
( more :: [(Symbol, Specification)])
:: (Global, [(Symbol, Specification)])
where
FoldReflectDefs2 '(spec, global) active name acc more =
FoldReflectDefs '(global, '(name, spec) : acc) active more
{-| Update the LHS of the definitions, to match the already updated globals -}
type family
RenameDefs
(global :: Global)
( defs :: [(Symbol, Specification)])
:: [(Symbol, Specification)]
where
RenameDefs globals '[] = '[]
RenameDefs (G globals) ( '(name, spec) : more) =
'(LookupNewName name globals, spec) : RenameDefs (G globals) more
type family
LookupNewName
(target :: Symbol)
( names :: [NameState])
:: Symbol
where
LookupNewName target (N target 0 : more) = target
LookupNewName target (N target ord : more) =
AppendSymbol target ( AppendSymbol "." ( ToSymbol ord))
LookupNewName target (N miss ord : more) =
LookupNewName target more
type family
ToSymbol
(o :: Nat)
:: Symbol
where
{-
We _could_ do some fancy stuff with type level mod and division
over Nat to handle an almost arbitrary number of name conflicts,
but for now handling 50 levels of name conflict seems sufficient.
-}
ToSymbol 1 = "1"
ToSymbol 2 = "2"
ToSymbol 3 = "3"
ToSymbol 4 = "4"
ToSymbol 5 = "5"
ToSymbol 6 = "6"
ToSymbol 7 = "7"
ToSymbol 8 = "8"
ToSymbol 9 = "9"
ToSymbol 10 = "10"
ToSymbol 11 = "11"
ToSymbol 12 = "12"
ToSymbol 13 = "13"
ToSymbol 14 = "14"
ToSymbol 15 = "15"
ToSymbol 16 = "16"
ToSymbol 17 = "17"
ToSymbol 18 = "18"
ToSymbol 19 = "19"
ToSymbol 20 = "20"
ToSymbol 21 = "21"
ToSymbol 22 = "22"
ToSymbol 23 = "23"
ToSymbol 24 = "24"
ToSymbol 25 = "25"
ToSymbol 26 = "26"
ToSymbol 27 = "27"
ToSymbol 28 = "28"
ToSymbol 29 = "29"
ToSymbol 30 = "30"
ToSymbol 31 = "31"
ToSymbol 32 = "32"
ToSymbol 33 = "33"
ToSymbol 34 = "34"
ToSymbol 35 = "35"
ToSymbol 36 = "36"
ToSymbol 37 = "37"
ToSymbol 38 = "38"
ToSymbol 39 = "39"
ToSymbol 40 = "40"
ToSymbol 41 = "41"
ToSymbol 42 = "42"
ToSymbol 43 = "43"
ToSymbol 44 = "44"
ToSymbol 45 = "45"
ToSymbol 46 = "46"
ToSymbol 47 = "47"
ToSymbol 48 = "48"
ToSymbol 49 = "49"
ToSymbol 50 = "50"
ToSymbol 51 = "51"
ToSymbol 52 = "52"
ToSymbol 53 = "53"
ToSymbol 54 = "54"
ToSymbol 55 = "55"
ToSymbol 56 = "56"
ToSymbol 57 = "57"
ToSymbol 58 = "58"
ToSymbol 59 = "59"
ToSymbol 60 = "60"
ToSymbol 61 = "61"
ToSymbol 62 = "62"
ToSymbol 63 = "63"
ToSymbol 64 = "64"
ToSymbol 65 = "65"
ToSymbol 66 = "66"
ToSymbol 67 = "67"
ToSymbol 68 = "68"
ToSymbol 69 = "69"
ToSymbol 70 = "70"
ToSymbol 71 = "71"
ToSymbol 72 = "72"
ToSymbol 73 = "73"
ToSymbol 74 = "74"
ToSymbol 75 = "75"
ToSymbol 76 = "76"
ToSymbol 77 = "77"
ToSymbol 78 = "78"
ToSymbol 79 = "79"
ToSymbol 80 = "80"
ToSymbol 81 = "81"
ToSymbol 82 = "82"
ToSymbol 83 = "83"
ToSymbol 84 = "84"
ToSymbol 85 = "85"
ToSymbol 86 = "86"
ToSymbol 87 = "87"
ToSymbol 88 = "88"
ToSymbol 89 = "89"
ToSymbol 90 = "90"
ToSymbol 91 = "91"
ToSymbol 92 = "92"
ToSymbol 93 = "93"
ToSymbol 94 = "94"
ToSymbol 95 = "95"
ToSymbol 96 = "96"
ToSymbol 97 = "97"
ToSymbol 98 = "98"
ToSymbol 99 = "99"
ToSymbol 100 = "100"
ToSymbol a =
TE.TypeError (
TE.Text "The author of json-spec-openapi was lazy and did"
:$$: TE.Text "not foresee that anyone would write a specification"
:$$: TE.Text "that would have to handle more than 100 collisions"
:$$: TE.Text "for a single name when converting to an OpenApi"
:$$: TE.Text "spec. Please submit a bug report on GitHub and"
:$$: TE.Text "I'll add a fix."
)
type family
MapSpec
(f :: Specification -> Specification)
(a :: (Specification, Global))
:: (Specification, Global)
where
MapSpec f '(a, b) = '(f a, b)
type family
Reverse
(acc :: [FieldSpec])
(list :: [FieldSpec])
:: [FieldSpec]
where
Reverse acc '[] = acc
Reverse acc (a : more) = Reverse (a : acc) more
data NameState = N
{ _name :: Symbol
, _ord :: Nat
}
newtype Global = G [NameState]
newtype Active = A [NameState]