-- | Extraction and unification of AutoType's @Type@ from Aeson @Value@.
module Data.Aeson.AutoType.Extract(valueSize, valueTypeSize,
                                   valueDepth, Dict(..),
                                   Type(..), emptyType,
                                   extractType, unifyTypes,
                                   typeCheck) where

import           Control.Arrow ((&&&))
import           Control.Exception               (assert)
import           Data.Aeson.AutoType.Type
import qualified Data.Graph          as Graph
import qualified Data.HashMap.Strict      as Map
import           Data.HashMap.Strict             (HashMap)
import qualified Data.Set                 as Set
import qualified Data.Vector              as V
import           Data.Aeson
import           Data.Text                       (Text)
import           Data.Set                        (Set )
import           Data.List                       (foldl1')
import           Data.Scientific                 (isInteger)

--import           Debug.Trace

-- | Compute total number of nodes (and leaves) within the value tree.
-- Each simple JavaScript type (including String) is counted as of size 1,
-- whereas both Array or object types are counted as 1+sum of the sizes
-- of their member values.
valueSize :: Value -> Int
valueSize :: Value -> Int
valueSize  Null      = 1
valueSize (Bool   _) = 1
valueSize (Number _) = 1
valueSize (String _) = 1
valueSize (Array  a :: Array
a) = (Int -> Int -> Int) -> Int -> Vector Int -> Int
forall a b. (a -> b -> a) -> a -> Vector b -> a
V.foldl' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) 1 (Vector Int -> Int) -> Vector Int -> Int
forall a b. (a -> b) -> a -> b
$ (Value -> Int) -> Array -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map Value -> Int
valueSize Array
a
valueSize (Object o :: Object
o) = (1Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (Object -> Int) -> Object -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Object -> [Int]) -> Object -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Int) -> [Value] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Int
valueSize ([Value] -> [Int]) -> (Object -> [Value]) -> Object -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Value]
forall k v. HashMap k v -> [v]
Map.elems (Object -> Int) -> Object -> Int
forall a b. (a -> b) -> a -> b
$ Object
o

-- | Compute total size of the type of the @Value@.
-- For:
-- * simple types it is always 1,
-- * for arrays it is just 1+_maximum_ size of the (single) element type,
-- * for objects it is _sum_ of the sizes of fields (since each field type
--   is assumed to be different.)
valueTypeSize :: Value -> Int
valueTypeSize :: Value -> Int
valueTypeSize  Null      = 1
valueTypeSize (Bool   _) = 1
valueTypeSize (Number _) = 1
valueTypeSize (String _) = 1
valueTypeSize (Array  a :: Array
a) = (1Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (Vector Int -> Int) -> Vector Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> Vector Int -> Int
forall a b. (a -> b -> a) -> a -> Vector b -> a
V.foldl' Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Vector Int -> Int) -> Vector Int -> Int
forall a b. (a -> b) -> a -> b
$ (Value -> Int) -> Array -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map Value -> Int
valueTypeSize Array
a
valueTypeSize (Object o :: Object
o) = (1Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (Object -> Int) -> Object -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Object -> [Int]) -> Object -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Int) -> [Value] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Int
valueTypeSize ([Value] -> [Int]) -> (Object -> [Value]) -> Object -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Value]
forall k v. HashMap k v -> [v]
Map.elems (Object -> Int) -> Object -> Int
forall a b. (a -> b) -> a -> b
$ Object
o

-- | Compute total depth of the value.
-- For:
-- * simple types it is 1
-- * for either Array or Object, it is 1 + maximum of depths of their members
valueDepth :: Value -> Int
valueDepth :: Value -> Int
valueDepth  Null      = 1
valueDepth (Bool   _) = 1
valueDepth (Number _) = 1
valueDepth (String _) = 1
valueDepth (Array  a :: Array
a) = (1Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (Vector Int -> Int) -> Vector Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> Vector Int -> Int
forall a b. (a -> b -> a) -> a -> Vector b -> a
V.foldl' Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Vector Int -> Int) -> Vector Int -> Int
forall a b. (a -> b) -> a -> b
$ (Value -> Int) -> Array -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map Value -> Int
valueDepth Array
a
valueDepth (Object o :: Object
o) = (1Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (Object -> Int) -> Object -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> (Object -> [Int]) -> Object -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> [Int]) -> (Object -> [Int]) -> Object -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Int) -> [Value] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Int
valueDepth ([Value] -> [Int]) -> (Object -> [Value]) -> Object -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Value]
forall k v. HashMap k v -> [v]
Map.elems (Object -> Int) -> Object -> Int
forall a b. (a -> b) -> a -> b
$ Object
o

-- | Check if a number is integral, or floating point
-- | Extract @Type@ from the JSON @Value@.
-- Unifying types of array elements, if necessary.
extractType                            :: Value -> Type
extractType :: Value -> Type
extractType (Object o :: Object
o)                  = Dict -> Type
TObj (Dict -> Type) -> Dict -> Type
forall a b. (a -> b) -> a -> b
$ Map Text Type -> Dict
Dict (Map Text Type -> Dict) -> Map Text Type -> Dict
forall a b. (a -> b) -> a -> b
$ (Value -> Type) -> Object -> Map Text Type
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map Value -> Type
extractType Object
o
extractType  Null                       = Type
TNull
extractType (Bool   _)                  = Type
TBool
extractType (Number n :: Scientific
n) | Scientific -> Bool
isInteger Scientific
n    = Type
TInt
extractType (Number _)                  = Type
TDouble
extractType (String _)                  = Type
TString
extractType (Array  a :: Array
a) | Array -> Bool
forall a. Vector a -> Bool
V.null Array
a       = Type -> Type
TArray   Type
emptyType
extractType (Array  a :: Array
a)                  = Type -> Type
TArray (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Vector Type -> Type
forall a. (a -> a -> a) -> Vector a -> a
V.foldl1' Type -> Type -> Type
unifyTypes (Vector Type -> Type) -> Vector Type -> Type
forall a b. (a -> b) -> a -> b
$ Vector Type -> Vector Type
forall a. a -> a
traceShow (Vector Type -> Vector Type) -> Vector Type -> Vector Type
forall a b. (a -> b) -> a -> b
$ (Value -> Type) -> Array -> Vector Type
forall a b. (a -> b) -> Vector a -> Vector b
V.map Value -> Type
extractType Array
a
  where
    --traceShow a = trace (show a) a
    traceShow :: a -> a
traceShow = a -> a
forall a. a -> a
id

-- | Type check the value with the derived type.
typeCheck :: Value -> Type -> Bool
typeCheck :: Value -> Type -> Bool
typeCheck  Null          TNull            = Bool
True
typeCheck  v :: Value
v            (TUnion  u :: Set Type
u)       = Value -> Type -> Bool
typeCheck Value
v (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` Set Type -> [Type]
forall a. Set a -> [a]
Set.toList Set Type
u
typeCheck (Bool   _)     TBool            = Bool
True
typeCheck (String _)     TString          = Bool
True
typeCheck (Number n :: Scientific
n)     TInt             = Scientific -> Bool
isInteger Scientific
n
typeCheck (Number _)     TDouble          = Bool
True
typeCheck (Array  elts :: Array
elts) (TArray  eltType :: Type
eltType) = (Value -> Type -> Bool
`typeCheck` Type
eltType) (Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`all` Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
elts
typeCheck (Object d :: Object
d)    (TObj    e :: Dict
e      ) = Text -> Bool
typeCheckKey (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`all` [Text]
keysOfBoth
  where
    typeCheckKey :: Text -> Bool
typeCheckKey k :: Text
k = Text -> Object -> Value
getValue Text
k Object
d Value -> Type -> Bool
`typeCheck` Text -> Dict -> Type
get Text
k Dict
e
    getValue   :: Text -> HashMap Text Value -> Value
    getValue :: Text -> Object -> Value
getValue    = Value -> Text -> Object -> Value
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault Value
Null
    keysOfBoth :: [Text]
    keysOfBoth :: [Text]
keysOfBoth  =  Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList (Object -> [Text]
forall k v. HashMap k v -> [k]
Map.keys Object
d) Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Dict -> Set Text
keys Dict
e
typeCheck         _     (TLabel  _      ) = [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error "Cannot typecheck labels without environment!"
typeCheck   {-a-} _      _ {-b-}          = {-trace msg $-} Bool
False
  where
    -- msg = "Mismatch: " ++ show a ++ " :: " ++ show b

allKeys :: Dict -> Dict -> [Text]
d :: Dict
d allKeys :: Dict -> Dict -> [Text]
`allKeys` e :: Dict
e = Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Dict -> Set Text
keys Dict
d Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Dict -> Set Text
keys Dict
e)

-- | Standard unification procedure on @Type@s,
-- with inclusion of @Type@ unions.
unifyTypes :: Type -> Type -> Type
unifyTypes :: Type -> Type -> Type
unifyTypes  TBool      TBool     = Type
TBool
unifyTypes  TInt       TInt      = Type
TInt
unifyTypes  TDouble    TInt      = Type
TDouble
unifyTypes  TInt       TDouble   = Type
TDouble
unifyTypes  TDouble    TDouble   = Type
TDouble
unifyTypes  TString    TString   = Type
TString
unifyTypes  TNull      TNull     = Type
TNull
unifyTypes (TObj   d :: Dict
d) (TObj   e :: Dict
e) = Dict -> Type
TObj Dict
newDict
  where
    newDict :: Dict
    newDict :: Dict
newDict = Map Text Type -> Dict
Dict (Map Text Type -> Dict) -> Map Text Type -> Dict
forall a b. (a -> b) -> a -> b
$ [(Text, Type)] -> Map Text Type
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(Text
k, Text -> Dict -> Type
get Text
k Dict
d Type -> Type -> Type
`unifyTypes`
                                        Text -> Dict -> Type
get Text
k Dict
e) | Text
k <- Dict -> Dict -> [Text]
allKeys Dict
d Dict
e ]
unifyTypes (TArray u :: Type
u) (TArray v :: Type
v) = Type -> Type
TArray (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type
u Type -> Type -> Type
`unifyTypes` Type
v
unifyTypes t :: Type
t           s :: Type
s         = Type -> Set Type
typeAsSet Type
t Set Type -> Set Type -> Type
`unifyUnion` Type -> Set Type
typeAsSet Type
s

-- | Unify sets of types (sets are union types of alternatives).
unifyUnion :: Set Type -> Set Type -> Type
unifyUnion :: Set Type -> Set Type -> Type
unifyUnion u :: Set Type
u v :: Set Type
v = Type -> Type
forall a. a -> a
assertions (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                   Set Type -> Type
union (Set Type -> Type) -> Set Type -> Type
forall a b. (a -> b) -> a -> b
$ Set Type
uSimple        Set Type -> Set Type -> Set Type
forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                           Set Type
vSimple        Set Type -> Set Type -> Set Type
forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                           Set Type
unifiedObjects Set Type -> Set Type -> Set Type
forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                           Type -> Set Type
forall a. a -> Set a
Set.singleton Type
unifiedArray
  where
    -- We partition our types for easier unification into simple and compound
    (uSimple :: Set Type
uSimple, uCompound :: Set Type
uCompound) = (Type -> Bool) -> Set Type -> (Set Type, Set Type)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition Type -> Bool
isSimple Set Type
u
    (vSimple :: Set Type
vSimple, vCompound :: Set Type
vCompound) = (Type -> Bool) -> Set Type -> (Set Type, Set Type)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition Type -> Bool
isSimple Set Type
v
    assertions :: c -> c
assertions = Bool -> c -> c
forall a. HasCallStack => Bool -> a -> a
assert (Set Type -> Bool
forall a. Set a -> Bool
Set.null (Set Type -> Bool) -> Set Type -> Bool
forall a b. (a -> b) -> a -> b
$ (Type -> Bool) -> Set Type -> Set Type
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isArray) Set Type
uArr) (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 Bool -> c -> c
forall a. HasCallStack => Bool -> a -> a
assert (Set Type -> Bool
forall a. Set a -> Bool
Set.null (Set Type -> Bool) -> Set Type -> Bool
forall a b. (a -> b) -> a -> b
$ (Type -> Bool) -> Set Type -> Set Type
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isArray) Set Type
vArr)
    -- then we partition compound typs into objects and arrays.
    -- Note that there should be no TUnion here, since we are inside a TUnion already.
    -- (That is reduced by @union@ smart costructor as superfluous.)
    (uObj :: Set Type
uObj, uArr :: Set Type
uArr)   = (Type -> Bool) -> Set Type -> (Set Type, Set Type)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition Type -> Bool
isObject Set Type
uCompound
    (vObj :: Set Type
vObj, vArr :: Set Type
vArr)   = (Type -> Bool) -> Set Type -> (Set Type, Set Type)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition Type -> Bool
isObject Set Type
vCompound
    unifiedObjects :: Set Type
unifiedObjects = [Type] -> Set Type
forall a. Ord a => [a] -> Set a
Set.fromList ([Type] -> Set Type) -> [Type] -> Set Type
forall a b. (a -> b) -> a -> b
$ if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
objects
                                       then []
                                       else [(Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
foldl1' Type -> Type -> Type
unifyTypes [Type]
objects]
    objects :: [Type]
objects = Set Type -> [Type]
forall a. Set a -> [a]
Set.toList (Set Type -> [Type]) -> Set Type -> [Type]
forall a b. (a -> b) -> a -> b
$ Set Type
uObj Set Type -> Set Type -> Set Type
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Type
vObj
    arrayElts :: [Type]
    arrayElts :: [Type]
arrayElts  = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\(TArray ty :: Type
ty) -> Type
ty) ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
                   Set Type -> [Type]
forall a. Set a -> [a]
Set.toList (Set Type -> [Type]) -> Set Type -> [Type]
forall a b. (a -> b) -> a -> b
$
                     Set Type
uArr Set Type -> Set Type -> Set Type
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Type
vArr
    unifiedArray :: Type
unifiedArray = Type -> Type
TArray (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
arrayElts
                               then Type
emptyType
                               else (Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
foldl1' Type -> Type -> Type
unifyTypes [Type]
arrayElts

-- | Smart constructor for union types.
union ::  Set Type -> Type
union :: Set Type -> Type
union = Type -> Type
simplifyUnion (Type -> Type) -> (Set Type -> Type) -> Set Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Type -> Type
TUnion

-- | Simplify TUnion's so there is no TUnion directly inside TUnion.
-- If there is only one element of the set, then return this single
-- element as a type.
simplifyUnion :: Type -> Type
simplifyUnion :: Type -> Type
simplifyUnion (TUnion s :: Set Type
s) | Set Type -> Int
forall a. Set a -> Int
Set.size Set Type
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = [Type] -> Type
forall a. [a] -> a
head ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ Set Type -> [Type]
forall a. Set a -> [a]
Set.toList Set Type
s
simplifyUnion (TUnion s :: Set Type
s)                   = Set Type -> Type
TUnion (Set Type -> Type) -> Set Type -> Type
forall a b. (a -> b) -> a -> b
$ [Set Type] -> Set Type
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Type] -> Set Type) -> [Set Type] -> Set Type
forall a b. (a -> b) -> a -> b
$ (Type -> Set Type) -> [Type] -> [Set Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Set Type
elements ([Type] -> [Set Type]) -> [Type] -> [Set Type]
forall a b. (a -> b) -> a -> b
$ Set Type -> [Type]
forall a. Set a -> [a]
Set.toList Set Type
s
  where
    elements :: Type -> Set Type
elements (TUnion elems :: Set Type
elems) = Set Type
elems
    elements sing :: Type
sing           = Type -> Set Type
forall a. a -> Set a
Set.singleton Type
sing
simplifyUnion unexpected :: Type
unexpected                   = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error ("simplifyUnion: unexpected argument " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
unexpected)