{-# LANGUAGE CPP                 #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGuaGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGuaGE DeriveGeneric       #-}
{-# LANGuaGE FlexibleContexts    #-}
-- | Formatting type declarations and class instances for inferred types.
module JsonToType.CodeGen.HaskellFormat(
  displaySplitTypes, normalizeTypeName,
  normalizeFieldName, formatType
) 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.Format
import           JsonToType.Split (toposort)
import           JsonToType.Util  ()

--import           Debug.Trace -- DEBUG
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

data DeclState = DeclState { DeclState -> [Text]
_decls   :: [Text]
                           , DeclState -> Int
_counter :: Int
                           }
  deriving (DeclState -> DeclState -> Bool
(DeclState -> DeclState -> Bool)
-> (DeclState -> DeclState -> Bool) -> Eq DeclState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeclState -> DeclState -> Bool
== :: DeclState -> DeclState -> Bool
$c/= :: DeclState -> DeclState -> Bool
/= :: DeclState -> DeclState -> Bool
Eq, Int -> DeclState -> ShowS
[DeclState] -> ShowS
DeclState -> [Char]
(Int -> DeclState -> ShowS)
-> (DeclState -> [Char])
-> ([DeclState] -> ShowS)
-> Show DeclState
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeclState -> ShowS
showsPrec :: Int -> DeclState -> ShowS
$cshow :: DeclState -> [Char]
show :: DeclState -> [Char]
$cshowList :: [DeclState] -> ShowS
showList :: [DeclState] -> ShowS
Show, Eq DeclState
Eq DeclState =>
(DeclState -> DeclState -> Ordering)
-> (DeclState -> DeclState -> Bool)
-> (DeclState -> DeclState -> Bool)
-> (DeclState -> DeclState -> Bool)
-> (DeclState -> DeclState -> Bool)
-> (DeclState -> DeclState -> DeclState)
-> (DeclState -> DeclState -> DeclState)
-> Ord DeclState
DeclState -> DeclState -> Bool
DeclState -> DeclState -> Ordering
DeclState -> DeclState -> DeclState
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DeclState -> DeclState -> Ordering
compare :: DeclState -> DeclState -> Ordering
$c< :: DeclState -> DeclState -> Bool
< :: DeclState -> DeclState -> Bool
$c<= :: DeclState -> DeclState -> Bool
<= :: DeclState -> DeclState -> Bool
$c> :: DeclState -> DeclState -> Bool
> :: DeclState -> DeclState -> Bool
$c>= :: DeclState -> DeclState -> Bool
>= :: DeclState -> DeclState -> Bool
$cmax :: DeclState -> DeclState -> DeclState
max :: DeclState -> DeclState -> DeclState
$cmin :: DeclState -> DeclState -> DeclState
min :: DeclState -> DeclState -> DeclState
Ord, (forall x. DeclState -> Rep DeclState x)
-> (forall x. Rep DeclState x -> DeclState) -> Generic DeclState
forall x. Rep DeclState x -> DeclState
forall x. DeclState -> Rep DeclState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DeclState -> Rep DeclState x
from :: forall x. DeclState -> Rep DeclState x
$cto :: forall x. Rep DeclState x -> DeclState
to :: forall x. Rep DeclState x -> DeclState
Generic)

makeLenses ''DeclState

type DeclM = State DeclState

type Map k v = Map.HashMap k v

stepM :: DeclM Int
stepM :: DeclM Int
stepM = (Int -> (Int, Int)) -> DeclState -> (Int, DeclState)
Lens' DeclState Int
counter ((Int -> (Int, Int)) -> DeclState -> (Int, DeclState))
-> (Int -> (Int, Int)) -> DeclM Int
forall {k} s (m :: * -> *) (p :: k -> * -> *) r (a :: k) b.
MonadState s m =>
Over p ((,) r) s s a b -> p a (r, b) -> m r
%%= (\Int
i -> (Int
i, Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))

tShow :: (Show a) => a -> Text
tShow :: forall a. Show a => a -> Text
tShow = [Char] -> Text
Text.pack ([Char] -> Text) -> (a -> [Char]) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show

-- | Wrap a type alias.
wrapAlias :: Text -> Text -> Text
wrapAlias :: Text -> Text -> Text
wrapAlias Text
identifier Text
contents = [Text] -> Text
Text.unwords [Text
"type", Text
identifier, Text
"=", Text
contents]

-- | Wrap a data type declaration
wrapDecl ::  Text -> Text -> Text
wrapDecl :: Text -> Text -> Text
wrapDecl Text
identifier Text
contents = [Text] -> Text
Text.unlines [Text
header, Text
contents, Text
"  } deriving (Show,Eq,GHC.Generics.Generic)"]
                                            --,"\nderiveJSON defaultOptions ''" `Text.append` identifier]
  where
    header :: Text
header = [Text] -> Text
Text.concat [Text
"data ", Text
identifier, Text
" = ", Text
identifier, Text
" { "]

-- | Explanatory type alias for making declarations
-- First element of the triple is original JSON identifier,
-- second element of the triple is the mapped identifier name in Haskell.
-- third element of the triple shows the type in a formatted way
type MappedKey = (Text, Text, Text, Bool)

-- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys
-- from JSON to Haskell identifiers *in the same order* as in *data type declaration*.
makeFromJSON ::  Text -> [MappedKey] -> Text
makeFromJSON :: Text -> [MappedKey] -> Text
makeFromJSON Text
identifier [MappedKey]
contents =
  [Text] -> Text
Text.unlines [
      [Text] -> Text
Text.unwords [Text
"instance FromJSON", Text
identifier, Text
"where"]
    , [Text] -> Text
Text.unwords [Text
"  parseJSON (Object v) =", Text -> [MappedKey] -> Text
forall {a}. Text -> [a] -> Text
makeParser Text
identifier [MappedKey]
contents]
    , Text
"  parseJSON _          = mzero" ]
  where
    makeParser :: Text -> [a] -> Text
makeParser Text
identifier [] = [Text] -> Text
Text.unwords [Text
"return ", Text
identifier]
    makeParser Text
identifier [a]
_  = [Text] -> Text
Text.unwords [Text
identifier, Text
"<$>", Text
inner]
    inner :: Text
inner                    = Text
" <*> " Text -> [Text] -> Text
`Text.intercalate`
                                  (MappedKey -> Text) -> [MappedKey] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map MappedKey -> Text
forall {b} {c}. (Text, b, c, Bool) -> Text
takeValue [MappedKey]
contents
    takeValue :: (Text, b, c, Bool) -> Text
takeValue (Text
jsonId, b
_, c
ty, Bool
True ) = [Text] -> Text
Text.concat [Text
"v .:? \"", Text
jsonId, Text
"\""] -- nullable types
    takeValue (Text
jsonId, b
_, c
_ , Bool
False) = [Text] -> Text
Text.concat [Text
"v .:  \"", Text
jsonId, Text
"\""]
-- Contents example for wrapFromJSON:
-- " <$>
--"                           v .: "hexValue"  <*>
--"                           v .: "colorName\""

-- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys
-- from JSON to Haskell identifiers in the same order as in declaration
makeToJSON :: Text -> [MappedKey] -> Text
makeToJSON :: Text -> [MappedKey] -> Text
makeToJSON Text
identifier [MappedKey]
contents =
    [Text] -> Text
Text.unlines [
        [Text] -> Text
Text.concat [Text
"instance ToJSON ", Text
identifier, Text
" where"]
      , [Text] -> Text
Text.concat [Text
"  toJSON     (", Text
identifier, Text
" {", Text
wildcard, Text
"}) = object [", Text -> Text
inner Text
", ", Text
"]"]
      , Text
maybeToEncoding
      ]
  where
    maybeToEncoding :: Text
maybeToEncoding | [MappedKey] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MappedKey]
contents = Text
""
                    | Bool
otherwise     =
                        [Text] -> Text
Text.concat [Text
"  toEncoding (", Text
identifier, Text
" {", Text
wildcard, Text
"}) = pairs  (", Text -> Text
inner Text
"<>", Text
")"]
    wildcard :: Text
wildcard | [MappedKey] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MappedKey]
contents = Text
""
             | Bool
otherwise     = Text
".."
    inner :: Text -> Text
inner Text
separator = Text
separator Text -> [Text] -> Text
`Text.intercalate`
                      (MappedKey -> Text) -> [MappedKey] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map MappedKey -> Text
forall {c} {d}. (Text, Text, c, d) -> Text
putValue [MappedKey]
contents
    putValue :: (Text, Text, c, d) -> Text
putValue (Text
jsonId, Text
haskellId, c
_typeText, d
_nullable) = [Text] -> Text
Text.unwords [Text -> Text
escapeText Text
jsonId, Text
".=", Text
haskellId]
    escapeText :: Text -> Text
escapeText = [Char] -> Text
Text.pack ([Char] -> Text) -> (Text -> [Char]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. Show a => a -> [Char]
show ShowS -> (Text -> [Char]) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack
-- Contents example for wrapToJSON
--"hexValue"  .= hexValue
--                                        ,"colorName" .= colorName]


-- | Makes a generic identifier name.
genericIdentifier :: DeclM Text
genericIdentifier :: DeclM Text
genericIdentifier = do
  Int
i <- DeclM Int
stepM
  Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> DeclM Text) -> Text -> DeclM Text
forall a b. (a -> b) -> a -> b
$! Text
"Obj" Text -> Text -> Text
`Text.append` Int -> Text
forall a. Show a => a -> Text
tShow Int
i

-- * Printing a single data type declaration
newDecl :: Text -> [(Text, Type)] -> DeclM Text
newDecl :: Text -> [(Text, Type)] -> DeclM Text
newDecl Text
identifier [(Text, Type)]
kvs = do [MappedKey]
attrs <- [(Text, Type)]
-> ((Text, Type) -> StateT DeclState Identity MappedKey)
-> StateT DeclState Identity [MappedKey]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, Type)]
kvs (((Text, Type) -> StateT DeclState Identity MappedKey)
 -> StateT DeclState Identity [MappedKey])
-> ((Text, Type) -> StateT DeclState Identity MappedKey)
-> StateT DeclState Identity [MappedKey]
forall a b. (a -> b) -> a -> b
$ \(Text
k, Type
v) -> do
                              Text
formatted <- Type -> DeclM Text
formatType Type
v
                              MappedKey -> StateT DeclState Identity MappedKey
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
k, Text -> Text -> Text
normalizeFieldName Text
identifier Text
k, Text
formatted, Type -> Bool
isNullable Type
v)
                            let decl :: Text
decl = [Text] -> Text
Text.unlines [Text -> Text -> Text
wrapDecl     Text
identifier (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [MappedKey] -> Text
fieldDecls [MappedKey]
attrs
                                                    ,Text
""
                                                    ,Text -> [MappedKey] -> Text
makeFromJSON Text
identifier              [MappedKey]
attrs
                                                    ,Text
""
                                                    ,Text -> [MappedKey] -> Text
makeToJSON   Text
identifier              [MappedKey]
attrs]
                            Text -> StateT DeclState Identity ()
forall {m :: * -> *}. MonadState DeclState m => Text -> m ()
addDecl Text
decl
                            Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
identifier
  where
    fieldDecls :: [MappedKey] -> Text
fieldDecls [MappedKey]
attrList = Text -> [Text] -> Text
Text.intercalate Text
",\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (MappedKey -> Text) -> [MappedKey] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map MappedKey -> Text
fieldDecl [MappedKey]
attrList
    fieldDecl :: (Text, Text, Text, Bool) -> Text
    fieldDecl :: MappedKey -> Text
fieldDecl (Text
_jsonName, Text
haskellName, Text
fType, Bool
_nullable) = [Text] -> Text
Text.concat [
                                                             Text
"    ", (Text -> Text
escapeKeywords Text
haskellName), Text
" :: ", Text
fType]

addDecl :: Text -> m ()
addDecl Text
decl = ([Text] -> ((), [Text])) -> DeclState -> ((), DeclState)
Lens' DeclState [Text]
decls (([Text] -> ((), [Text])) -> DeclState -> ((), DeclState))
-> ([Text] -> ((), [Text])) -> m ()
forall {k} s (m :: * -> *) (p :: k -> * -> *) r (a :: k) b.
MonadState s m =>
Over p ((,) r) s s a b -> p a (r, b) -> m r
%%= (\[Text]
ds -> ((), Text
declText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
ds))

-- | Add new type alias for Array type
newAlias :: Text -> Type -> DeclM Text
newAlias :: Text -> Type -> DeclM Text
newAlias Text
identifier Type
content = do Text
formatted <- Type -> DeclM Text
formatType Type
content
                                 Text -> StateT DeclState Identity ()
forall {m :: * -> *}. MonadState DeclState m => Text -> m ()
addDecl (Text -> StateT DeclState Identity ())
-> Text -> StateT DeclState Identity ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines [Text -> Text -> Text
wrapAlias Text
identifier Text
formatted]
                                 Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
identifier

-- | Convert a JSON key name given by second argument,
-- from within a dictionary keyed with first argument,
-- into a name of Haskell record field (hopefully distinct from other such selectors.)
normalizeFieldName ::  Text -> Text -> Text
normalizeFieldName :: Text -> Text -> Text
normalizeFieldName Text
identifier =  Text -> Text
escapeKeywords             (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                 Text -> Text
uncapitalize               (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                (Text -> Text
normalizeTypeName Text
identifier Text -> Text -> Text
`Text.append`) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                 Text -> Text
normalizeTypeName

keywords ::  Set Text
keywords :: Set Text
keywords = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text
"kind", Text
"type", Text
"data", Text
"module", Text
"class", Text
"where", Text
"let", Text
"do"]

escapeKeywords ::  Text -> Text
escapeKeywords :: Text -> Text
escapeKeywords Text
k | Text
k Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
keywords = Text
k Text -> Text -> Text
`Text.append` Text
"_"
escapeKeywords Text
k                           = Text
k

-- | Format the type within DeclM monad, that records
-- the separate declarations on which this one is dependent.
formatType :: Type -> DeclM Text
formatType :: Type -> DeclM Text
formatType  Type
TString                          = Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Text"
formatType  Type
TInt                             = Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Int"
formatType  Type
TDouble                          = Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Double"
formatType  Type
TBool                            = Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Bool"
formatType (TLabel Text
l)                        = Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> DeclM Text) -> Text -> DeclM Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
normalizeTypeName Text
l
formatType (TUnion Set Type
u)                        = Text -> Text
wrap (Text -> Text) -> DeclM Text -> DeclM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
nonNull of
                                                          Int
0 -> Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
emptyTypeRepr
                                                          Int
1 -> Type -> DeclM Text
formatType (Type -> DeclM Text) -> Type -> DeclM Text
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
forall a. (?callStack::CallStack) => [a] -> a
head [Type]
nonNull
                                                          Int
_ -> Text -> [Text] -> Text
Text.intercalate Text
":|:" ([Text] -> Text) -> StateT DeclState Identity [Text] -> DeclM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> DeclM Text) -> [Type] -> StateT DeclState Identity [Text]
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 Type -> DeclM Text
formatType [Type]
nonNull
  where
    nonNull :: [Type]
nonNull       = Set Type -> [Type]
forall a. Set a -> [a]
Set.toList (Set Type -> [Type]) -> Set Type -> [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Bool) -> Set Type -> Set Type
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Type
TNull Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/=) Set Type
u
    wrap                                :: Text -> Text
    wrap :: Text -> Text
wrap   Text
inner  | Type
TNull Type -> Set Type -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Type
u = [Text] -> Text
Text.concat [Text
"(Maybe (", Text
inner, Text
"))"]
                  | Bool
otherwise            =                          Text
inner
formatType (TArray Type
a)                        = do Text
inner <- Type -> DeclM Text
formatType Type
a
                                                  Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> DeclM Text) -> Text -> DeclM Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat [Text
"[", Text
inner, Text
"]"]
formatType (TObj   Dict
o)                        = do Text
ident <- DeclM Text
genericIdentifier
                                                  Text -> [(Text, Type)] -> DeclM Text
newDecl Text
ident [(Text, Type)]
d
  where
    d :: [(Text, Type)]
d = 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
formatType  Type
e | Type
e Type -> Set Type -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Type
emptySetLikes = Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
emptyTypeRepr
formatType  Type
t                                = Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> DeclM Text) -> Text -> DeclM Text
forall a b. (a -> b) -> a -> b
$ Text
"ERROR: Don't know how to handle: " Text -> Text -> Text
`Text.append` Type -> Text
forall a. Show a => a -> Text
tShow Type
t

emptyTypeRepr :: Text
emptyTypeRepr :: Text
emptyTypeRepr = Text
"(Maybe Value)" -- default, accepts future extension where we found no data

runDecl ::  DeclM a -> Text
runDecl :: forall a. DeclM a -> Text
runDecl DeclM a
decl = [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ DeclState
finalState DeclState -> Getting [Text] DeclState [Text] -> [Text]
forall s a. s -> Getting a s a -> a
^. Getting [Text] DeclState [Text]
Lens' DeclState [Text]
decls
  where
    initialState :: DeclState
initialState    = [Text] -> Int -> DeclState
DeclState [] Int
1
    (a
_, DeclState
finalState) = DeclM a -> DeclState -> (a, DeclState)
forall s a. State s a -> s -> (a, s)
runState DeclM a
decl DeclState
initialState

-- * Splitting object types by label for unification.
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) = Bool -> TypeTreeM Type -> TypeTreeM Type
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False (TypeTreeM Type -> TypeTreeM Type)
-> TypeTreeM Type -> TypeTreeM Type
forall a b. (a -> b) -> a -> b
$ 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
r -- unnecessary?
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

-- | Splits initial type with a given label, into a mapping of object type names and object type structures.
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. (?callStack::CallStack) => (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. (?callStack::CallStack) => 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

formatObjectType ::  Text -> Type -> DeclM Text
formatObjectType :: Text -> Type -> DeclM Text
formatObjectType Text
identifier (TObj Dict
o) = Text -> [(Text, Type)] -> DeclM Text
newDecl  Text
identifier [(Text, Type)]
d
  where
    d :: [(Text, Type)]
d = 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
formatObjectType Text
identifier  Type
other   = Text -> Type -> DeclM Text
newAlias Text
identifier Type
other

-- | Display an environment of types split by name.
displaySplitTypes ::  Map Text Type -> Text
displaySplitTypes :: HashMap Text Type -> Text
displaySplitTypes HashMap Text Type
dict = [Char] -> Text -> Text
forall {p} {p}. p -> p -> p
trace ([Char]
"displaySplitTypes: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Text, Type)] -> [Char]
forall a. Show a => a -> [Char]
show (HashMap Text Type -> [(Text, Type)]
toposort HashMap Text Type
dict)) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ StateT DeclState Identity [Text] -> Text
forall a. DeclM a -> Text
runDecl StateT DeclState Identity [Text]
declarations
  where
    declarations :: StateT DeclState Identity [Text]
declarations =
      [(Text, Type)]
-> ((Text, Type) -> DeclM Text) -> StateT DeclState Identity [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (HashMap Text Type -> [(Text, Type)]
toposort HashMap Text Type
dict) (((Text, Type) -> DeclM Text) -> StateT DeclState Identity [Text])
-> ((Text, Type) -> DeclM Text) -> StateT DeclState Identity [Text]
forall a b. (a -> b) -> a -> b
$ \(Text
name, Type
typ) ->
        Text -> Type -> DeclM Text
formatObjectType (Text -> Text
normalizeTypeName Text
name) Type
typ

-- | Normalize type name by:
-- 1. Treating all characters that are not acceptable in Haskell variable name as end of word.
-- 2. Capitalizing each word, but a first (camelCase).
-- 3. Adding underscore if first character is non-alphabetic.
-- 4. Escaping Haskell keywords if the whole identifier is such keyword.
-- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name.
normalizeTypeName :: Text -> Text
normalizeTypeName :: Text -> Text
normalizeTypeName = Text -> Text -> Text
forall {p}. (Eq p, IsString p) => p -> p -> p
ifEmpty Text
"JsonEmptyKey"                  (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    Text -> Text
ensureBeginsWithCapital                 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    Text -> Text
escapeKeywords                          (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    Text -> Text
escapeFirstNonAlpha                     (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    [Text] -> Text
Text.concat                             ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
capitalize                          ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter     (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    (Char -> Bool) -> Text -> [Text]
Text.split (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
acceptableInVariable)
  where
    ifEmpty :: p -> p -> p
ifEmpty p
x p
""       = p
x
    ifEmpty p
_ p
nonEmpty = p
nonEmpty
    ensureBeginsWithCapital :: Text -> Text
ensureBeginsWithCapital Text
x =
      if Text -> Text -> Bool
Text.isPrefixOf Text
"_" Text
x
      then Text
"D" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x
      else Text
x
    acceptableInVariable :: Char -> Bool
acceptableInVariable Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c
    escapeFirstNonAlpha :: Text -> Text
escapeFirstNonAlpha Text
cs                  | Text -> Bool
Text.null Text
cs =                   Text
cs
    escapeFirstNonAlpha cs :: Text
cs@((?callStack::CallStack) => Text -> Char
Text -> Char
Text.head -> Char
c) | Char -> Bool
isAlpha   Char
c  =                   Text
cs
    escapeFirstNonAlpha Text
cs                                 = Text
"_" Text -> Text -> Text
`Text.append` Text
cs

-- | Computes all type labels referenced by a given type.
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