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
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
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) = forall a. NFData a => a -> ()
rnf NormRecordType
x
rnf (NUnionType NormRecordType
x) = forall a. NFData a => a -> ()
rnf NormRecordType
x
rnf (NEnumType NormEnumType
x) = forall a. NFData a => a -> ()
rnf NormEnumType
x
rnf (NTypeSynonym APIType
x) = forall a. NFData a => a -> ()
rnf APIType
x
rnf (NNewtype BasicType
x) = 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 =
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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map NormTypeDecl -> Set TypeName
typeDeclFreeVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems
typeDeclFreeVars :: NormTypeDecl -> Set TypeName
typeDeclFreeVars :: NormTypeDecl -> Set TypeName
typeDeclFreeVars (NRecordType NormRecordType
fields) = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map APIType -> Set TypeName
typeFreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ NormRecordType
fields
typeDeclFreeVars (NUnionType NormRecordType
alts) = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map APIType -> Set TypeName
typeFreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ NormRecordType
alts
typeDeclFreeVars (NEnumType NormEnumType
_) = forall a. Set a
Set.empty
typeDeclFreeVars (NTypeSynonym APIType
t) = APIType -> Set TypeName
typeFreeVars APIType
t
typeDeclFreeVars (NNewtype BasicType
_) = 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) = forall a. a -> Set a
Set.singleton TypeName
n
typeFreeVars (TyBasic BasicType
_) = forall a. Set a
Set.empty
typeFreeVars APIType
TyJSON = forall a. Set a
Set.empty
typeDeclaredInApi :: TypeName -> NormAPI -> Bool
typeDeclaredInApi :: TypeName -> NormAPI -> Bool
typeDeclaredInApi TypeName
tname NormAPI
api = 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 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 forall a. Eq a => a -> a -> Bool
== TypeName
root Bool -> Bool -> Bool
|| TypeName
tname forall a. Ord a => a -> Set a -> Bool
`Set.member` NormAPI -> Set TypeName -> Set TypeName
transitiveDeps NormAPI
api (forall a. a -> Set a
Set.singleton TypeName
root)
transitiveDeps :: NormAPI -> Set TypeName -> Set TypeName
transitiveDeps :: NormAPI -> Set TypeName -> Set TypeName
transitiveDeps NormAPI
api = forall a. Ord a => (Set a -> Set a) -> Set a -> Set a
transitiveClosure forall a b. (a -> b) -> a -> b
$ \ Set TypeName
s ->
NormAPI -> Set TypeName
typeDeclsFreeVars forall a b. (a -> b) -> a -> b
$
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\ TypeName
x NormTypeDecl
_ -> TypeName
x 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 = forall a. Ord a => (Set a -> Set a) -> Set a -> Set a
transitiveClosure forall a b. (a -> b) -> a -> b
$ \ Set TypeName
s ->
forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall {a}. Ord a => Set a -> Set a -> Bool
intersects Set TypeName
s 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 forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ Set a
s1 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 :: forall a. Ord a => (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
| 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 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 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 forall {a}. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set TypeName
declaredTypes = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall a b. a -> Either a b
Left (Set TypeName
typeVars 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 = 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 forall {a}. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set TypeName
declaredTypes = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall a b. a -> Either a b
Left (Set TypeName
declVars 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 = 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 forall {a}. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set TypeName
declaredTypes = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall a b. a -> Either a b
Left (Set TypeName
usedTypes 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 = 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 (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 (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' = 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 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" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\ (FieldName
f, APIType
ty) -> String
" " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> String
pp FieldName
f
forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> String
pp APIType
ty)
(forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
flds)
ppLines (NUnionType NormRecordType
alts) = String
"union" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\ (FieldName
f, APIType
ty) -> String
" | " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> String
pp FieldName
f
forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> String
pp APIType
ty)
(forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
alts)
ppLines (NEnumType NormEnumType
vals) = String
"enum" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\ FieldName
v -> String
" | " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> String
pp FieldName
v)
(forall a. Set a -> [a]
Set.toList NormEnumType
vals)
ppLines (NTypeSynonym APIType
t) = [forall t. PP t => t -> String
pp APIType
t]
ppLines (NNewtype BasicType
b) = [String
"basic " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> String
pp BasicType
b]