module Data.API.NormalForm
(
NormAPI
, NormTypeDecl(..)
, NormRecordType
, NormUnionType
, NormEnumType
, apiNormalForm
, declNF
, typeDeclsFreeVars
, typeDeclFreeVars
, typeFreeVars
, typeDeclaredInApi
, typeUsedInApi
, typeUsedInTransitiveDep
, transitiveDeps
, transitiveReverseDeps
, apiInvariant
, declIsValid
, typeIsValid
, substTypeDecl
, substType
, renameTypeUses
) where
import Data.API.PP
import Data.API.Types
import Control.DeepSeq
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
type NormAPI = Map TypeName NormTypeDecl
data NormTypeDecl
= NRecordType NormRecordType
| NUnionType NormUnionType
| NEnumType NormEnumType
| NTypeSynonym APIType
| NNewtype BasicType
deriving (NormTypeDecl -> NormTypeDecl -> Bool
(NormTypeDecl -> NormTypeDecl -> Bool)
-> (NormTypeDecl -> NormTypeDecl -> Bool) -> Eq NormTypeDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NormTypeDecl -> NormTypeDecl -> Bool
$c/= :: NormTypeDecl -> NormTypeDecl -> Bool
== :: NormTypeDecl -> NormTypeDecl -> Bool
$c== :: NormTypeDecl -> NormTypeDecl -> Bool
Eq, Int -> NormTypeDecl -> ShowS
[NormTypeDecl] -> ShowS
NormTypeDecl -> String
(Int -> NormTypeDecl -> ShowS)
-> (NormTypeDecl -> String)
-> ([NormTypeDecl] -> ShowS)
-> Show NormTypeDecl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NormTypeDecl] -> ShowS
$cshowList :: [NormTypeDecl] -> ShowS
show :: NormTypeDecl -> String
$cshow :: NormTypeDecl -> String
showsPrec :: Int -> NormTypeDecl -> ShowS
$cshowsPrec :: Int -> NormTypeDecl -> ShowS
Show)
instance NFData NormTypeDecl where
rnf :: NormTypeDecl -> ()
rnf (NRecordType NormRecordType
x) = NormRecordType -> ()
forall a. NFData a => a -> ()
rnf NormRecordType
x
rnf (NUnionType NormRecordType
x) = NormRecordType -> ()
forall a. NFData a => a -> ()
rnf NormRecordType
x
rnf (NEnumType NormEnumType
x) = NormEnumType -> ()
forall a. NFData a => a -> ()
rnf NormEnumType
x
rnf (NTypeSynonym APIType
x) = APIType -> ()
forall a. NFData a => a -> ()
rnf APIType
x
rnf (NNewtype BasicType
x) = BasicType -> ()
forall a. NFData a => a -> ()
rnf BasicType
x
type NormRecordType = Map FieldName APIType
type NormUnionType = Map FieldName APIType
type = Set FieldName
apiNormalForm :: API -> NormAPI
apiNormalForm :: API -> NormAPI
apiNormalForm API
api =
[(TypeName, NormTypeDecl)] -> NormAPI
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (TypeName
name, Spec -> NormTypeDecl
declNF Spec
spec)
| ThNode (APINode {anName :: APINode -> TypeName
anName = TypeName
name, anSpec :: APINode -> Spec
anSpec = Spec
spec}) <- API
api ]
declNF :: Spec -> NormTypeDecl
declNF :: Spec -> NormTypeDecl
declNF (SpRecord (SpecRecord [(FieldName, FieldType)]
fields)) = NormRecordType -> NormTypeDecl
NRecordType (NormRecordType -> NormTypeDecl) -> NormRecordType -> NormTypeDecl
forall a b. (a -> b) -> a -> b
$ [(FieldName, APIType)] -> NormRecordType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (FieldName
fname, FieldType -> APIType
ftType FieldType
ftype)
| (FieldName
fname, FieldType
ftype) <- [(FieldName, FieldType)]
fields ]
declNF (SpUnion (SpecUnion [(FieldName, (APIType, String))]
alts)) = NormRecordType -> NormTypeDecl
NUnionType (NormRecordType -> NormTypeDecl) -> NormRecordType -> NormTypeDecl
forall a b. (a -> b) -> a -> b
$ [(FieldName, APIType)] -> NormRecordType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (FieldName
fname, APIType
ftype)
| (FieldName
fname, (APIType
ftype, String
_)) <- [(FieldName, (APIType, String))]
alts ]
declNF (SpEnum (SpecEnum [(FieldName, String)]
elems)) = NormEnumType -> NormTypeDecl
NEnumType (NormEnumType -> NormTypeDecl) -> NormEnumType -> NormTypeDecl
forall a b. (a -> b) -> a -> b
$ [FieldName] -> NormEnumType
forall a. Ord a => [a] -> Set a
Set.fromList
[ FieldName
fname | (FieldName
fname, String
_) <- [(FieldName, String)]
elems ]
declNF (SpSynonym APIType
t) = APIType -> NormTypeDecl
NTypeSynonym APIType
t
declNF (SpNewtype (SpecNewtype BasicType
bt Maybe Filter
_)) = BasicType -> NormTypeDecl
NNewtype BasicType
bt
typeDeclsFreeVars :: NormAPI -> Set TypeName
typeDeclsFreeVars :: NormAPI -> Set TypeName
typeDeclsFreeVars = [Set TypeName] -> Set TypeName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set TypeName] -> Set TypeName)
-> (NormAPI -> [Set TypeName]) -> NormAPI -> Set TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NormTypeDecl -> Set TypeName) -> [NormTypeDecl] -> [Set TypeName]
forall a b. (a -> b) -> [a] -> [b]
map NormTypeDecl -> Set TypeName
typeDeclFreeVars ([NormTypeDecl] -> [Set TypeName])
-> (NormAPI -> [NormTypeDecl]) -> NormAPI -> [Set TypeName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormAPI -> [NormTypeDecl]
forall k a. Map k a -> [a]
Map.elems
typeDeclFreeVars :: NormTypeDecl -> Set TypeName
typeDeclFreeVars :: NormTypeDecl -> Set TypeName
typeDeclFreeVars (NRecordType NormRecordType
fields) = [Set TypeName] -> Set TypeName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set TypeName] -> Set TypeName)
-> (NormRecordType -> [Set TypeName])
-> NormRecordType
-> Set TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (APIType -> Set TypeName) -> [APIType] -> [Set TypeName]
forall a b. (a -> b) -> [a] -> [b]
map APIType -> Set TypeName
typeFreeVars
([APIType] -> [Set TypeName])
-> (NormRecordType -> [APIType])
-> NormRecordType
-> [Set TypeName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormRecordType -> [APIType]
forall k a. Map k a -> [a]
Map.elems (NormRecordType -> Set TypeName) -> NormRecordType -> Set TypeName
forall a b. (a -> b) -> a -> b
$ NormRecordType
fields
typeDeclFreeVars (NUnionType NormRecordType
alts) = [Set TypeName] -> Set TypeName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set TypeName] -> Set TypeName)
-> (NormRecordType -> [Set TypeName])
-> NormRecordType
-> Set TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (APIType -> Set TypeName) -> [APIType] -> [Set TypeName]
forall a b. (a -> b) -> [a] -> [b]
map APIType -> Set TypeName
typeFreeVars
([APIType] -> [Set TypeName])
-> (NormRecordType -> [APIType])
-> NormRecordType
-> [Set TypeName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormRecordType -> [APIType]
forall k a. Map k a -> [a]
Map.elems (NormRecordType -> Set TypeName) -> NormRecordType -> Set TypeName
forall a b. (a -> b) -> a -> b
$ NormRecordType
alts
typeDeclFreeVars (NEnumType NormEnumType
_) = Set TypeName
forall a. Set a
Set.empty
typeDeclFreeVars (NTypeSynonym APIType
t) = APIType -> Set TypeName
typeFreeVars APIType
t
typeDeclFreeVars (NNewtype BasicType
_) = Set TypeName
forall a. Set a
Set.empty
typeFreeVars :: APIType -> Set TypeName
typeFreeVars :: APIType -> Set TypeName
typeFreeVars (TyList APIType
t) = APIType -> Set TypeName
typeFreeVars APIType
t
typeFreeVars (TyMaybe APIType
t) = APIType -> Set TypeName
typeFreeVars APIType
t
typeFreeVars (TyName TypeName
n) = TypeName -> Set TypeName
forall a. a -> Set a
Set.singleton TypeName
n
typeFreeVars (TyBasic BasicType
_) = Set TypeName
forall a. Set a
Set.empty
typeFreeVars APIType
TyJSON = Set TypeName
forall a. Set a
Set.empty
typeDeclaredInApi :: TypeName -> NormAPI -> Bool
typeDeclaredInApi :: TypeName -> NormAPI -> Bool
typeDeclaredInApi TypeName
tname NormAPI
api = TypeName -> NormAPI -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TypeName
tname NormAPI
api
typeUsedInApi :: TypeName -> NormAPI -> Bool
typeUsedInApi :: TypeName -> NormAPI -> Bool
typeUsedInApi TypeName
tname NormAPI
api = TypeName
tname TypeName -> Set TypeName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` NormAPI -> Set TypeName
typeDeclsFreeVars NormAPI
api
typeUsedInTransitiveDep :: TypeName -> TypeName -> NormAPI -> Bool
typeUsedInTransitiveDep :: TypeName -> TypeName -> NormAPI -> Bool
typeUsedInTransitiveDep TypeName
root TypeName
tname NormAPI
api =
TypeName
tname TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeName
root Bool -> Bool -> Bool
|| TypeName
tname TypeName -> Set TypeName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` NormAPI -> Set TypeName -> Set TypeName
transitiveDeps NormAPI
api (TypeName -> Set TypeName
forall a. a -> Set a
Set.singleton TypeName
root)
transitiveDeps :: NormAPI -> Set TypeName -> Set TypeName
transitiveDeps :: NormAPI -> Set TypeName -> Set TypeName
transitiveDeps NormAPI
api = (Set TypeName -> Set TypeName) -> Set TypeName -> Set TypeName
forall a. Ord a => (Set a -> Set a) -> Set a -> Set a
transitiveClosure ((Set TypeName -> Set TypeName) -> Set TypeName -> Set TypeName)
-> (Set TypeName -> Set TypeName) -> Set TypeName -> Set TypeName
forall a b. (a -> b) -> a -> b
$ \ Set TypeName
s ->
NormAPI -> Set TypeName
typeDeclsFreeVars (NormAPI -> Set TypeName) -> NormAPI -> Set TypeName
forall a b. (a -> b) -> a -> b
$
(TypeName -> NormTypeDecl -> Bool) -> NormAPI -> NormAPI
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\ TypeName
x NormTypeDecl
_ -> TypeName
x TypeName -> Set TypeName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TypeName
s) NormAPI
api
transitiveReverseDeps :: NormAPI -> Set TypeName -> Set TypeName
transitiveReverseDeps :: NormAPI -> Set TypeName -> Set TypeName
transitiveReverseDeps NormAPI
api = (Set TypeName -> Set TypeName) -> Set TypeName -> Set TypeName
forall a. Ord a => (Set a -> Set a) -> Set a -> Set a
transitiveClosure ((Set TypeName -> Set TypeName) -> Set TypeName -> Set TypeName)
-> (Set TypeName -> Set TypeName) -> Set TypeName -> Set TypeName
forall a b. (a -> b) -> a -> b
$ \ Set TypeName
s ->
NormAPI -> Set TypeName
forall k a. Map k a -> Set k
Map.keysSet (NormAPI -> Set TypeName) -> NormAPI -> Set TypeName
forall a b. (a -> b) -> a -> b
$
(NormTypeDecl -> Bool) -> NormAPI -> NormAPI
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Set TypeName -> Set TypeName -> Bool
forall a. Ord a => Set a -> Set a -> Bool
intersects Set TypeName
s (Set TypeName -> Bool)
-> (NormTypeDecl -> Set TypeName) -> NormTypeDecl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormTypeDecl -> Set TypeName
typeDeclFreeVars) NormAPI
api
where
intersects :: Set a -> Set a -> Bool
intersects Set a
s1 Set a
s2 = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set a -> Bool
forall a. Set a -> Bool
Set.null (Set a -> Bool) -> Set a -> Bool
forall a b. (a -> b) -> a -> b
$ Set a
s1 Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set a
s2
transitiveClosure :: Ord a => (Set a -> Set a) -> Set a -> Set a
transitiveClosure :: (Set a -> Set a) -> Set a -> Set a
transitiveClosure Set a -> Set a
rel Set a
x = Set a -> Set a -> Set a
findUsed Set a
x0 Set a
x0
where
x0 :: Set a
x0 = Set a -> Set a
rel Set a
x
findUsed :: Set a -> Set a -> Set a
findUsed Set a
seen Set a
old
| Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
new = Set a
seen
| Bool
otherwise = Set a -> Set a -> Set a
findUsed (Set a
seen Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set a
new) Set a
new
where
new :: Set a
new = Set a -> Set a
rel Set a
old Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set a
seen
typeIsValid :: APIType -> NormAPI -> Either (Set TypeName) ()
typeIsValid :: APIType -> NormAPI -> Either (Set TypeName) ()
typeIsValid APIType
t NormAPI
api
| Set TypeName
typeVars Set TypeName -> Set TypeName -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set TypeName
declaredTypes = () -> Either (Set TypeName) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = Set TypeName -> Either (Set TypeName) ()
forall a b. a -> Either a b
Left (Set TypeName
typeVars Set TypeName -> Set TypeName -> Set TypeName
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set TypeName
declaredTypes)
where
typeVars :: Set TypeName
typeVars = APIType -> Set TypeName
typeFreeVars APIType
t
declaredTypes :: Set TypeName
declaredTypes = NormAPI -> Set TypeName
forall k a. Map k a -> Set k
Map.keysSet NormAPI
api
declIsValid :: NormTypeDecl -> NormAPI -> Either (Set TypeName) ()
declIsValid :: NormTypeDecl -> NormAPI -> Either (Set TypeName) ()
declIsValid NormTypeDecl
decl NormAPI
api
| Set TypeName
declVars Set TypeName -> Set TypeName -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set TypeName
declaredTypes = () -> Either (Set TypeName) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = Set TypeName -> Either (Set TypeName) ()
forall a b. a -> Either a b
Left (Set TypeName
declVars Set TypeName -> Set TypeName -> Set TypeName
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set TypeName
declaredTypes)
where
declVars :: Set TypeName
declVars = NormTypeDecl -> Set TypeName
typeDeclFreeVars NormTypeDecl
decl
declaredTypes :: Set TypeName
declaredTypes = NormAPI -> Set TypeName
forall k a. Map k a -> Set k
Map.keysSet NormAPI
api
apiInvariant :: NormAPI -> Either (Set TypeName) ()
apiInvariant :: NormAPI -> Either (Set TypeName) ()
apiInvariant NormAPI
api
| Set TypeName
usedTypes Set TypeName -> Set TypeName -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set TypeName
declaredTypes = () -> Either (Set TypeName) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = Set TypeName -> Either (Set TypeName) ()
forall a b. a -> Either a b
Left (Set TypeName
usedTypes Set TypeName -> Set TypeName -> Set TypeName
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set TypeName
declaredTypes)
where
usedTypes :: Set TypeName
usedTypes = NormAPI -> Set TypeName
typeDeclsFreeVars NormAPI
api
declaredTypes :: Set TypeName
declaredTypes = NormAPI -> Set TypeName
forall k a. Map k a -> Set k
Map.keysSet NormAPI
api
substTypeDecl :: (TypeName -> APIType) -> NormTypeDecl -> NormTypeDecl
substTypeDecl :: (TypeName -> APIType) -> NormTypeDecl -> NormTypeDecl
substTypeDecl TypeName -> APIType
f (NRecordType NormRecordType
fields) = NormRecordType -> NormTypeDecl
NRecordType ((APIType -> APIType) -> NormRecordType -> NormRecordType
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((TypeName -> APIType) -> APIType -> APIType
substType TypeName -> APIType
f) NormRecordType
fields)
substTypeDecl TypeName -> APIType
f (NUnionType NormRecordType
alts) = NormRecordType -> NormTypeDecl
NUnionType ((APIType -> APIType) -> NormRecordType -> NormRecordType
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((TypeName -> APIType) -> APIType -> APIType
substType TypeName -> APIType
f) NormRecordType
alts)
substTypeDecl TypeName -> APIType
_ d :: NormTypeDecl
d@(NEnumType NormEnumType
_) = NormTypeDecl
d
substTypeDecl TypeName -> APIType
f (NTypeSynonym APIType
t) = APIType -> NormTypeDecl
NTypeSynonym ((TypeName -> APIType) -> APIType -> APIType
substType TypeName -> APIType
f APIType
t)
substTypeDecl TypeName -> APIType
_ d :: NormTypeDecl
d@(NNewtype BasicType
_) = NormTypeDecl
d
substType :: (TypeName -> APIType) -> APIType -> APIType
substType :: (TypeName -> APIType) -> APIType -> APIType
substType TypeName -> APIType
f (TyList APIType
t) = APIType -> APIType
TyList ((TypeName -> APIType) -> APIType -> APIType
substType TypeName -> APIType
f APIType
t)
substType TypeName -> APIType
f (TyMaybe APIType
t) = APIType -> APIType
TyMaybe ((TypeName -> APIType) -> APIType -> APIType
substType TypeName -> APIType
f APIType
t)
substType TypeName -> APIType
f (TyName TypeName
n) = TypeName -> APIType
f TypeName
n
substType TypeName -> APIType
_ t :: APIType
t@(TyBasic BasicType
_) = APIType
t
substType TypeName -> APIType
_ t :: APIType
t@APIType
TyJSON = APIType
t
renameTypeUses :: TypeName -> TypeName -> NormAPI -> NormAPI
renameTypeUses :: TypeName -> TypeName -> NormAPI -> NormAPI
renameTypeUses TypeName
tname TypeName
tname' = (NormTypeDecl -> NormTypeDecl) -> NormAPI -> NormAPI
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((TypeName -> APIType) -> NormTypeDecl -> NormTypeDecl
substTypeDecl TypeName -> APIType
rename)
where
rename :: TypeName -> APIType
rename TypeName
tn | TypeName
tn TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeName
tname = TypeName -> APIType
TyName TypeName
tname'
| Bool
otherwise = TypeName -> APIType
TyName TypeName
tn
instance PPLines NormTypeDecl where
ppLines :: NormTypeDecl -> [String]
ppLines (NRecordType NormRecordType
flds) = String
"record" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((FieldName, APIType) -> String)
-> [(FieldName, APIType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (FieldName
f, APIType
ty) -> String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
f
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ APIType -> String
forall t. PP t => t -> String
pp APIType
ty)
(NormRecordType -> [(FieldName, APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
flds)
ppLines (NUnionType NormRecordType
alts) = String
"union" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((FieldName, APIType) -> String)
-> [(FieldName, APIType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (FieldName
f, APIType
ty) -> String
" | " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
f
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ APIType -> String
forall t. PP t => t -> String
pp APIType
ty)
(NormRecordType -> [(FieldName, APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
alts)
ppLines (NEnumType NormEnumType
vals) = String
"enum" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (FieldName -> String) -> [FieldName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ FieldName
v -> String
" | " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
v)
(NormEnumType -> [FieldName]
forall a. Set a -> [a]
Set.toList NormEnumType
vals)
ppLines (NTypeSynonym APIType
t) = [APIType -> String
forall t. PP t => t -> String
pp APIType
t]
ppLines (NNewtype BasicType
b) = [String
"basic " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BasicType -> String
forall t. PP t => t -> String
pp BasicType
b]