{-# LANGUAGE CPP                 #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGuaGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGuaGE DeriveGeneric       #-}
{-# LANGuaGE FlexibleContexts    #-}
-- | Formatting type declarations and class instances for inferred types. 
module Data.Aeson.AutoType.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           Data.Aeson.AutoType.Type
import           Data.Aeson.AutoType.Extract
import           Data.Aeson.AutoType.Format
import           Data.Aeson.AutoType.Split (toposort)
import           Data.Aeson.AutoType.Util  ()

--import           Debug.Trace -- DEBUG
trace :: p -> p -> p
trace _ x :: p
x = p
x

fst3 ::  (t, t1, t2) -> t
fst3 :: (t, t1, t2) -> t
fst3 (a :: t
a, _b :: t1
_b, _c :: 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
/= :: DeclState -> DeclState -> Bool
$c/= :: DeclState -> DeclState -> Bool
== :: DeclState -> DeclState -> Bool
$c== :: DeclState -> DeclState -> Bool
Eq, Int -> DeclState -> ShowS
[DeclState] -> ShowS
DeclState -> String
(Int -> DeclState -> ShowS)
-> (DeclState -> String)
-> ([DeclState] -> ShowS)
-> Show DeclState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeclState] -> ShowS
$cshowList :: [DeclState] -> ShowS
show :: DeclState -> String
$cshow :: DeclState -> String
showsPrec :: Int -> DeclState -> ShowS
$cshowsPrec :: Int -> 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
min :: DeclState -> DeclState -> DeclState
$cmin :: DeclState -> DeclState -> DeclState
max :: DeclState -> DeclState -> DeclState
$cmax :: DeclState -> DeclState -> DeclState
>= :: DeclState -> DeclState -> Bool
$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
compare :: DeclState -> DeclState -> Ordering
$ccompare :: DeclState -> DeclState -> Ordering
$cp1Ord :: Eq 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
$cto :: forall x. Rep DeclState x -> DeclState
$cfrom :: forall x. DeclState -> Rep DeclState x
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
%%= (\i :: Int
i -> (Int
i, Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1))

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

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

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

-- | 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 identifier :: Text
identifier contents :: [MappedKey]
contents =
  [Text] -> Text
Text.unlines [
      [Text] -> Text
Text.unwords ["instance FromJSON", Text
identifier, "where"]
    , [Text] -> Text
Text.unwords ["  parseJSON (Object v) =", Text -> [MappedKey] -> Text
forall a. Text -> [a] -> Text
makeParser Text
identifier [MappedKey]
contents]
    , "  parseJSON _          = mzero" ]
  where
    makeParser :: Text -> [a] -> Text
makeParser identifier :: Text
identifier [] = [Text] -> Text
Text.unwords ["return ", Text
identifier]
    makeParser identifier :: Text
identifier _  = [Text] -> Text
Text.unwords [Text
identifier, "<$>", Text
inner]
    inner :: Text
inner                    = " <*> " 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 (jsonId :: Text
jsonId, _, ty :: c
ty, True ) = [Text] -> Text
Text.concat ["v .:? \"", Text
jsonId, "\""] -- nullable types
    takeValue (jsonId :: Text
jsonId, _, _ , False) = [Text] -> Text
Text.concat ["v .:  \"", Text
jsonId, "\""]
-- 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 identifier :: Text
identifier contents :: [MappedKey]
contents =
    [Text] -> Text
Text.unlines [
        [Text] -> Text
Text.concat ["instance ToJSON ", Text
identifier, " where"]
      , [Text] -> Text
Text.concat ["  toJSON     (", Text
identifier, " {", Text
wildcard, "}) = object [", Text -> Text
inner ", ", "]"]
      , Text
maybeToEncoding
      ]
  where
    maybeToEncoding :: Text
maybeToEncoding | [MappedKey] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MappedKey]
contents = ""
                    | Bool
otherwise     =
                        [Text] -> Text
Text.concat ["  toEncoding (", Text
identifier, " {", Text
wildcard, "}) = pairs  (", Text -> Text
inner "<>", ")"]
    wildcard :: Text
wildcard | [MappedKey] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MappedKey]
contents = ""
             | Bool
otherwise     = ".."
    inner :: Text -> Text
inner separator :: 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 (jsonId :: Text
jsonId, haskellId :: Text
haskellId, _typeText :: c
_typeText, _nullable :: d
_nullable) = [Text] -> Text
Text.unwords [Text -> Text
escapeText Text
jsonId, ".=", Text
haskellId]
    escapeText :: Text -> Text
escapeText = String -> Text
Text.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. Show a => a -> String
show ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
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 (m :: * -> *) a. Monad m => a -> m a
return (Text -> DeclM Text) -> Text -> DeclM Text
forall a b. (a -> b) -> a -> b
$! "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 identifier :: Text
identifier kvs :: [(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
$ \(k :: Text
k, v :: Type
v) -> do
                              Text
formatted <- Type -> DeclM Text
formatType Type
v
                              MappedKey -> StateT DeclState Identity MappedKey
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 -> [MappedKey] -> Text
makeFromJSON Text
identifier              [MappedKey]
attrs
                                                    ,""
                                                    ,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 (m :: * -> *) a. Monad m => a -> m a
return Text
identifier
  where
    fieldDecls :: [MappedKey] -> Text
fieldDecls attrList :: [MappedKey]
attrList = Text -> [Text] -> Text
Text.intercalate ",\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 (_jsonName :: Text
_jsonName, haskellName :: Text
haskellName, fType :: Text
fType, _nullable :: Bool
_nullable) = [Text] -> Text
Text.concat [
                                                             "    ", (Text -> Text
escapeKeywords Text
haskellName), " :: ", Text
fType]

addDecl :: Text -> m ()
addDecl decl :: 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
%%= (\ds :: [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 identifier :: Text
identifier content :: 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 (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 identifier :: 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 ["kind", "type", "data", "module", "class", "where", "let", "do"]

escapeKeywords ::  Text -> Text
escapeKeywords :: Text -> Text
escapeKeywords k :: 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` "_"
escapeKeywords k :: 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  TString                          = Text -> DeclM Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Text"
formatType  TInt                             = Text -> DeclM Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Int"
formatType  TDouble                          = Text -> DeclM Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Double"
formatType  TBool                            = Text -> DeclM Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Bool"
formatType (TLabel l :: Text
l)                        = Text -> DeclM Text
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 u :: 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 (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
nonNull of
                                                          0 -> Text -> DeclM Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
emptyTypeRepr
                                                          1 -> Type -> DeclM Text
formatType (Type -> DeclM Text) -> Type -> DeclM Text
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
forall a. [a] -> a
head [Type]
nonNull
                                                          _ -> Text -> [Text] -> Text
Text.intercalate ":|:" ([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)
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   inner :: 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 ["(Maybe (", Text
inner, "))"]
                  | Bool
otherwise            =                          Text
inner
formatType (TArray a :: Type
a)                        = do Text
inner <- Type -> DeclM Text
formatType Type
a
                                                  Text -> DeclM Text
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
inner, "]"]
formatType (TObj   o :: 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  e :: 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 (m :: * -> *) a. Monad m => a -> m a
return Text
emptyTypeRepr
formatType  t :: Type
t                                = Text -> DeclM Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> DeclM Text) -> Text -> DeclM Text
forall a b. (a -> b) -> a -> b
$ "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 = "(Maybe Value)" -- default, accepts future extension where we found no data

runDecl ::  DeclM a -> Text
runDecl :: DeclM a -> Text
runDecl decl :: 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 [] 1
    (_, finalState :: 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 label :: Text
label typ :: 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' _  TString   = Type -> TypeTreeM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TString
splitTypeByLabel' _  TInt      = Type -> TypeTreeM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
splitTypeByLabel' _  TDouble   = Type -> TypeTreeM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TDouble
splitTypeByLabel' _  TBool     = Type -> TypeTreeM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
splitTypeByLabel' _  TNull     = Type -> TypeTreeM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TNull
splitTypeByLabel' _ (TLabel r :: 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 (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' l :: Text
l (TUnion u :: 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)
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 (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' l :: Text
l (TArray a :: Type
a) = do Type
m <- Text -> Type -> TypeTreeM Type
splitTypeByLabel' (Text
l Text -> Text -> Text
`Text.append` "Elt") Type
a
                                    Type -> TypeTreeM Type
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' l :: Text
l (TObj   o :: 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
$ \(k :: Text
k, v :: Type
v) -> do
                                       Type
component <- Text -> Type -> TypeTreeM Type
splitTypeByLabel' Text
k Type
v
                                       (Text, Type) -> StateT (HashMap Text [Type]) Identity (Text, Type)
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 (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 topLabel :: Text
topLabel t :: 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. (a -> a -> a) -> [a] -> a
foldl1' Type -> Type -> Type
unifyTypes) HashMap Text [Type]
finalState
  where
    finalize :: Type -> TypeTreeM ()
finalize (TLabel l :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()
    finalize  topLevel :: 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
    (_, finalState :: 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 (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 identifier :: Text
identifier (TObj o :: 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 identifier :: Text
identifier  other :: 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 dict :: HashMap Text Type
dict = String -> Text -> Text
forall p p. p -> p -> p
trace ("displaySplitTypes: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Text, Type)] -> String
forall a. Show a => a -> String
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
$ \(name :: Text
name, typ :: 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 "JsonEmptyKey"                  (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 x :: p
x ""       = p
x
    ifEmpty _ nonEmpty :: p
nonEmpty = p
nonEmpty
    acceptableInVariable :: Char -> Bool
acceptableInVariable c :: Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c
    escapeFirstNonAlpha :: Text -> Text
escapeFirstNonAlpha cs :: Text
cs                  | Text -> Bool
Text.null Text
cs =                   Text
cs
    escapeFirstNonAlpha cs :: Text
cs@(Text -> Char
Text.head -> Char
c) | Char -> Bool
isAlpha   Char
c  =                   Text
cs
    escapeFirstNonAlpha cs :: Text
cs                                 = "_" 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 l :: Text
l) ls :: [Text]
ls = Text
lText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
ls
    go (TArray t :: Type
t) ls :: [Text]
ls = Type -> [Text] -> [Text]
go Type
t [Text]
ls
    go (TUnion u :: Set Type
u) ls :: [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   o :: Dict
o) ls :: [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 _other :: Type
_other     ls :: [Text]
ls = [Text]
ls