{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGuaGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGuaGE DeriveGeneric #-}
{-# LANGuaGE FlexibleContexts #-}
module JsonToType.Split(
splitTypeByLabel, unificationCandidates,
unifyCandidates, toposort
) where
import Control.Arrow ((&&&))
import Control.Applicative ((<$>), (<*>))
import Control.Lens.TH
import Control.Lens
import Control.Monad (forM)
import Control.Exception(assert)
import qualified Data.HashMap.Strict as Map
import Data.Monoid
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Text (Text)
import Data.Set (Set )
import Data.List (foldl1')
import Data.Char (isAlpha, isDigit)
import Control.Monad.State.Class
import Control.Monad.State.Strict(State, runState)
import qualified Data.Graph as Graph
import GHC.Generics (Generic)
import JsonToType.Type
import JsonToType.Extract
import JsonToType.Util ()
trace :: p -> p -> p
trace p
_ p
x = p
x
fst3 :: (t, t1, t2) -> t
fst3 :: forall t t1 t2. (t, t1, t2) -> t
fst3 (t
a, t1
_b, t2
_c) = t
a
type Map k v = Map.HashMap k v
type MappedKey = (Text, Text, Text, Bool)
type TypeTree = Map Text [Type]
type TypeTreeM a = State TypeTree a
addType :: Text -> Type -> TypeTreeM ()
addType :: Text -> Type -> TypeTreeM ()
addType Text
label Type
typ = (HashMap Text [Type] -> HashMap Text [Type]) -> TypeTreeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((HashMap Text [Type] -> HashMap Text [Type]) -> TypeTreeM ())
-> (HashMap Text [Type] -> HashMap Text [Type]) -> TypeTreeM ()
forall a b. (a -> b) -> a -> b
$ ([Type] -> [Type] -> [Type])
-> Text -> [Type] -> HashMap Text [Type] -> HashMap Text [Type]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
Map.insertWith [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
(++) Text
label [Type
typ]
splitTypeByLabel' :: Text -> Type -> TypeTreeM Type
splitTypeByLabel' :: Text -> Type -> TypeTreeM Type
splitTypeByLabel' Text
_ Type
TString = Type -> TypeTreeM Type
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TString
splitTypeByLabel' Text
_ Type
TInt = Type -> TypeTreeM Type
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
splitTypeByLabel' Text
_ Type
TDouble = Type -> TypeTreeM Type
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TDouble
splitTypeByLabel' Text
_ Type
TBool = Type -> TypeTreeM Type
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
splitTypeByLabel' Text
_ Type
TNull = Type -> TypeTreeM Type
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TNull
splitTypeByLabel' Text
_ (TLabel Text
r) = [Char] -> TypeTreeM Type
forall a. HasCallStack => [Char] -> a
error ([Char] -> TypeTreeM Type) -> [Char] -> TypeTreeM Type
forall a b. (a -> b) -> a -> b
$ [Char]
"Splitting into labelled types after label "
[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
r [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" was already given!"
splitTypeByLabel' Text
l (TUnion Set Type
u) = do [Type]
m <- (Type -> TypeTreeM Type)
-> [Type] -> StateT (HashMap Text [Type]) Identity [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Text -> Type -> TypeTreeM Type
splitTypeByLabel' Text
l) ([Type] -> StateT (HashMap Text [Type]) Identity [Type])
-> [Type] -> StateT (HashMap Text [Type]) Identity [Type]
forall a b. (a -> b) -> a -> b
$ Set Type -> [Type]
forall a. Set a -> [a]
Set.toList Set Type
u
Type -> TypeTreeM Type
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TypeTreeM Type) -> Type -> TypeTreeM Type
forall a b. (a -> b) -> a -> b
$! Set Type -> Type
TUnion (Set Type -> Type) -> Set Type -> Type
forall a b. (a -> b) -> a -> b
$! [Type] -> Set Type
forall a. Ord a => [a] -> Set a
Set.fromList [Type]
m
splitTypeByLabel' Text
l (TArray Type
a) = do Type
m <- Text -> Type -> TypeTreeM Type
splitTypeByLabel' (Text
l Text -> Text -> Text
`Text.append` Text
"Elt") Type
a
Type -> TypeTreeM Type
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TypeTreeM Type) -> Type -> TypeTreeM Type
forall a b. (a -> b) -> a -> b
$! Type -> Type
TArray Type
m
splitTypeByLabel' Text
l (TObj Dict
o) = do [(Text, Type)]
kvs <- [(Text, Type)]
-> ((Text, Type)
-> StateT (HashMap Text [Type]) Identity (Text, Type))
-> StateT (HashMap Text [Type]) Identity [(Text, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (HashMap Text Type -> [(Text, Type)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (HashMap Text Type -> [(Text, Type)])
-> HashMap Text Type -> [(Text, Type)]
forall a b. (a -> b) -> a -> b
$ Dict -> HashMap Text Type
unDict Dict
o) (((Text, Type)
-> StateT (HashMap Text [Type]) Identity (Text, Type))
-> StateT (HashMap Text [Type]) Identity [(Text, Type)])
-> ((Text, Type)
-> StateT (HashMap Text [Type]) Identity (Text, Type))
-> StateT (HashMap Text [Type]) Identity [(Text, Type)]
forall a b. (a -> b) -> a -> b
$ \(Text
k, Type
v) -> do
Type
component <- Text -> Type -> TypeTreeM Type
splitTypeByLabel' Text
k Type
v
(Text, Type) -> StateT (HashMap Text [Type]) Identity (Text, Type)
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
k, Type
component)
Text -> Type -> TypeTreeM ()
addType Text
l (Dict -> Type
TObj (Dict -> Type) -> Dict -> Type
forall a b. (a -> b) -> a -> b
$ HashMap Text Type -> Dict
Dict (HashMap Text Type -> Dict) -> HashMap Text Type -> Dict
forall a b. (a -> b) -> a -> b
$ [(Text, Type)] -> HashMap Text Type
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(Text, Type)]
kvs)
Type -> TypeTreeM Type
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TypeTreeM Type) -> Type -> TypeTreeM Type
forall a b. (a -> b) -> a -> b
$! Text -> Type
TLabel Text
l
splitTypeByLabel :: Text -> Type -> Map Text Type
splitTypeByLabel :: Text -> Type -> HashMap Text Type
splitTypeByLabel Text
topLabel Type
t = ([Type] -> Type) -> HashMap Text [Type] -> HashMap Text Type
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map ((Type -> Type -> Type) -> [Type] -> Type
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Type -> Type -> Type
unifyTypes) HashMap Text [Type]
finalState
where
finalize :: Type -> TypeTreeM ()
finalize (TLabel Text
l) = Bool -> TypeTreeM () -> TypeTreeM ()
forall a. HasCallStack => Bool -> a -> a
assert (Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
topLabel) (TypeTreeM () -> TypeTreeM ()) -> TypeTreeM () -> TypeTreeM ()
forall a b. (a -> b) -> a -> b
$ () -> TypeTreeM ()
forall a. a -> StateT (HashMap Text [Type]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
finalize Type
topLevel = Text -> Type -> TypeTreeM ()
addType Text
topLabel Type
topLevel
initialState :: HashMap k v
initialState = HashMap k v
forall k v. HashMap k v
Map.empty
(()
_, HashMap Text [Type]
finalState) = TypeTreeM () -> HashMap Text [Type] -> ((), HashMap Text [Type])
forall s a. State s a -> s -> (a, s)
runState (Text -> Type -> TypeTreeM Type
splitTypeByLabel' Text
topLabel Type
t TypeTreeM Type -> (Type -> TypeTreeM ()) -> TypeTreeM ()
forall a b.
StateT (HashMap Text [Type]) Identity a
-> (a -> StateT (HashMap Text [Type]) Identity b)
-> StateT (HashMap Text [Type]) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> TypeTreeM ()
finalize) HashMap Text [Type]
forall k v. HashMap k v
initialState
toposort :: Map Text Type -> [(Text, Type)]
toposort :: HashMap Text Type -> [(Text, Type)]
toposort HashMap Text Type
splitted = (Vertex -> (Text, Type)) -> [Vertex] -> [(Text, Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text
forall a. a -> a
id (Text -> Text) -> (Text -> Type) -> Text -> (Text, Type)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (HashMap Text Type
splitted HashMap Text Type -> Text -> Type
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
Map.!)) (Text -> (Text, Type))
-> (Vertex -> Text) -> Vertex -> (Text, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text, [Text]) -> Text
forall t t1 t2. (t, t1, t2) -> t
fst3 ((Text, Text, [Text]) -> Text)
-> (Vertex -> (Text, Text, [Text])) -> Vertex -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vertex -> (Text, Text, [Text])
graphKey) ([Vertex] -> [(Text, Type)]) -> [Vertex] -> [(Text, Type)]
forall a b. (a -> b) -> a -> b
$ Graph -> [Vertex]
Graph.topSort Graph
graph
where
(Graph
graph, Vertex -> (Text, Text, [Text])
graphKey) = [(Text, Text, [Text])] -> (Graph, Vertex -> (Text, Text, [Text]))
forall key node.
Ord key =>
[(node, key, [key])] -> (Graph, Vertex -> (node, key, [key]))
Graph.graphFromEdges' ([(Text, Text, [Text])] -> (Graph, Vertex -> (Text, Text, [Text])))
-> [(Text, Text, [Text])]
-> (Graph, Vertex -> (Text, Text, [Text]))
forall a b. (a -> b) -> a -> b
$ ((Text, Type) -> (Text, Text, [Text]))
-> [(Text, Type)] -> [(Text, Text, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Type) -> (Text, Text, [Text])
forall {b}. (b, Type) -> (b, b, [Text])
makeEntry ([(Text, Type)] -> [(Text, Text, [Text])])
-> [(Text, Type)] -> [(Text, Text, [Text])]
forall a b. (a -> b) -> a -> b
$ HashMap Text Type -> [(Text, Type)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap Text Type
splitted
makeEntry :: (b, Type) -> (b, b, [Text])
makeEntry (b
k, Type
v) = (b
k, b
k, Type -> [Text]
allLabels Type
v)
allLabels :: Type -> [Text]
allLabels :: Type -> [Text]
allLabels = (Type -> [Text] -> [Text]) -> [Text] -> Type -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> [Text] -> [Text]
go []
where
go :: Type -> [Text] -> [Text]
go (TLabel Text
l) [Text]
ls = Text
lText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
ls
go (TArray Type
t) [Text]
ls = Type -> [Text] -> [Text]
go Type
t [Text]
ls
go (TUnion Set Type
u) [Text]
ls = (Type -> [Text] -> [Text]) -> [Text] -> Set Type -> [Text]
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Type -> [Text] -> [Text]
go [Text]
ls Set Type
u
go (TObj Dict
o) [Text]
ls = (Type -> [Text] -> [Text]) -> [Text] -> HashMap Text Type -> [Text]
forall v a k. (v -> a -> a) -> a -> HashMap k v -> a
Map.foldr Type -> [Text] -> [Text]
go [Text]
ls (HashMap Text Type -> [Text]) -> HashMap Text Type -> [Text]
forall a b. (a -> b) -> a -> b
$ Dict -> HashMap Text Type
unDict Dict
o
go Type
_other [Text]
ls = [Text]
ls
unificationCandidates :: Map.HashMap t Type -> [[t]]
unificationCandidates :: forall t. HashMap t Type -> [[t]]
unificationCandidates = HashMap (Set Text) [t] -> [[t]]
forall k v. HashMap k v -> [v]
Map.elems (HashMap (Set Text) [t] -> [[t]])
-> (HashMap t Type -> HashMap (Set Text) [t])
-> HashMap t Type
-> [[t]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
([t] -> Bool) -> HashMap (Set Text) [t] -> HashMap (Set Text) [t]
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
Map.filter [t] -> Bool
forall {a}. [a] -> Bool
candidates (HashMap (Set Text) [t] -> HashMap (Set Text) [t])
-> (HashMap t Type -> HashMap (Set Text) [t])
-> HashMap t Type
-> HashMap (Set Text) [t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
([t] -> [t] -> [t]) -> [(Set Text, [t])] -> HashMap (Set Text) [t]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith [t] -> [t] -> [t]
forall a. [a] -> [a] -> [a]
(++) ([(Set Text, [t])] -> HashMap (Set Text) [t])
-> (HashMap t Type -> [(Set Text, [t])])
-> HashMap t Type
-> HashMap (Set Text) [t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((t, Type) -> [(Set Text, [t])])
-> [(t, Type)] -> [(Set Text, [t])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (t, Type) -> [(Set Text, [t])]
forall {a}. (a, Type) -> [(Set Text, [a])]
entry ([(t, Type)] -> [(Set Text, [t])])
-> (HashMap t Type -> [(t, Type)])
-> HashMap t Type
-> [(Set Text, [t])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
HashMap t Type -> [(t, Type)]
forall k v. HashMap k v -> [(k, v)]
Map.toList
where
candidates :: [a] -> Bool
candidates [ ] = Bool
False
candidates [a
_] = Bool
False
candidates [a]
_ = Bool
True
entry :: (a, Type) -> [(Set Text, [a])]
entry (a
k, TObj Dict
o) = [([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ HashMap Text Type -> [Text]
forall k v. HashMap k v -> [k]
Map.keys (HashMap Text Type -> [Text]) -> HashMap Text Type -> [Text]
forall a b. (a -> b) -> a -> b
$ Dict -> HashMap Text Type
unDict Dict
o, [a
k])]
entry (a, Type)
_ = []
unifyCandidates :: [[Text]] -> Map Text Type -> Map Text Type
unifyCandidates :: [[Text]] -> HashMap Text Type -> HashMap Text Type
unifyCandidates [[Text]]
candidates HashMap Text Type
splitted = (Type -> Type) -> HashMap Text Type -> HashMap Text Type
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map (Map Text Text -> Type -> Type
remapLabels Map Text Text
labelMapping) (HashMap Text Type -> HashMap Text Type)
-> HashMap Text Type -> HashMap Text Type
forall a b. (a -> b) -> a -> b
$ HashMap Text Type -> HashMap Text Type
replacements HashMap Text Type
splitted
where
unifiedType :: [Text] -> Type
unifiedType :: [Text] -> Type
unifiedType [Text]
cset = (Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
unifyTypes ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$
(Text -> Type) -> [Text] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (HashMap Text Type
splitted HashMap Text Type -> Text -> Type
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
Map.!) [Text]
cset
replace :: [Text] -> Map Text Type -> Map Text Type
replace :: [Text] -> HashMap Text Type -> HashMap Text Type
replace cset :: [Text]
cset@(Text
c:[Text]
_) HashMap Text Type
s = Text -> Type -> HashMap Text Type -> HashMap Text Type
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Text
c ([Text] -> Type
unifiedType [Text]
cset) ((Text -> HashMap Text Type -> HashMap Text Type)
-> HashMap Text Type -> [Text] -> HashMap Text Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> HashMap Text Type -> HashMap Text Type
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete HashMap Text Type
s [Text]
cset)
replace [] HashMap Text Type
_ = [Char] -> HashMap Text Type
forall a. HasCallStack => [Char] -> a
error [Char]
"Empty candidate set in replace"
replacements :: Map Text Type -> Map Text Type
replacements :: HashMap Text Type -> HashMap Text Type
replacements HashMap Text Type
s = ([Text] -> HashMap Text Type -> HashMap Text Type)
-> HashMap Text Type -> [[Text]] -> HashMap Text Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Text] -> HashMap Text Type -> HashMap Text Type
replace HashMap Text Type
s [[Text]]
candidates
labelMapping :: Map Text Text
labelMapping :: Map Text Text
labelMapping = [(Text, Text)] -> Map Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Text)] -> Map Text Text)
-> [(Text, Text)] -> Map Text Text
forall a b. (a -> b) -> a -> b
$ ([Text] -> [(Text, Text)]) -> [[Text]] -> [(Text, Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Text] -> [(Text, Text)]
forall {b}. [b] -> [(b, b)]
mapEntry [[Text]]
candidates
mapEntry :: [b] -> [(b, b)]
mapEntry cset :: [b]
cset@(b
c:[b]
_) = [(b
x, b
c) | b
x <- [b]
cset]
mapEntry [] = [Char] -> [(b, b)]
forall a. HasCallStack => [Char] -> a
error [Char]
"Empty candidate set in mapEntry"
remapLabels :: Map Text Text -> Type -> Type
remapLabels :: Map Text Text -> Type -> Type
remapLabels Map Text Text
ls (TObj Dict
o) = Dict -> Type
TObj (Dict -> Type) -> Dict -> Type
forall a b. (a -> b) -> a -> b
$ HashMap Text Type -> Dict
Dict (HashMap Text Type -> Dict) -> HashMap Text Type -> Dict
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> HashMap Text Type -> HashMap Text Type
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map (Map Text Text -> Type -> Type
remapLabels Map Text Text
ls) (HashMap Text Type -> HashMap Text Type)
-> HashMap Text Type -> HashMap Text Type
forall a b. (a -> b) -> a -> b
$ Dict -> HashMap Text Type
unDict Dict
o
remapLabels Map Text Text
ls (TArray Type
t) = Type -> Type
TArray (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Map Text Text -> Type -> Type
remapLabels Map Text Text
ls Type
t
remapLabels Map Text Text
ls (TUnion Set Type
u) = Set Type -> Type
TUnion (Set Type -> Type) -> Set Type -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> Set Type -> Set Type
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Map Text Text -> Type -> Type
remapLabels Map Text Text
ls) Set Type
u
remapLabels Map Text Text
ls (TLabel Text
l) = Text -> Type
TLabel (Text -> Type) -> Text -> Type
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Map Text Text -> Text
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault Text
l Text
l Map Text Text
ls
remapLabels Map Text Text
_ Type
other = Type
other