{-# 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.ElmFormat(
  displaySplitTypes,
  normalizeTypeName) 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, toList)
import           Data.List                 (foldl1')
import           Data.Char                 (isAlpha, isDigit)
import           Control.Monad.State.Class
import           Control.Monad.State.Strict(State, runState)
import           GHC.Generics              (Generic)

import           JsonToType.Type
import           JsonToType.Extract
import           JsonToType.Split
import           JsonToType.Format
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 alias ", 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
"  }"]
                                            --,"\nderiveJSON defaultOptions ''" `Text.append` identifier]
  where
    header :: Text
header = [Text] -> Text
Text.concat [Text
"type alias ", Text
identifier, Text
" = ", 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, Type, Bool)

-- | Make Decoder 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*.
makeDecoder ::  Text -> [MappedKey] -> Text
makeDecoder :: Text -> [MappedKey] -> Text
makeDecoder Text
identifier [MappedKey]
contents =
  [Text] -> Text
Text.unlines [
      [Text] -> Text
Text.concat  [Text
decodeIdentifier, Text
" : Json.Decode.Decoder ", Text
identifier]
    , [Text] -> Text
Text.concat  [Text
decodeIdentifier, Text
" ="]
    , [Text] -> Text
Text.unwords [Text
"    Json.Decode.Pipeline.decode", Text
identifier]
    , [Text] -> Text
Text.unlines (Text -> MappedKey -> Text
forall {p} {b} {c}. p -> (Text, b, c, Type, Bool) -> Text
makeParser Text
identifier (MappedKey -> Text) -> [MappedKey] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MappedKey]
contents) ]
  where
    decodeIdentifier :: Text
decodeIdentifier         = Text -> Text
decoderIdent Text
identifier
    makeParser :: p -> (Text, b, c, Type, Bool) -> Text
makeParser p
identifier (Text
jsonId, b
_, c
_, Type
ty, Bool
isOptional) = [Text] -> Text
Text.unwords [
          Text
"  |>"
        , if Bool
isOptional
             then Text
"Json.Decode.Pipeline.optional"
             else Text
"Json.Decode.Pipeline.required"
        , [Text] -> Text
Text.concat [Text
"\"", Text
jsonId, Text
"\""]
        , Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
getDecoder Type
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"] -- quote

getDecoder :: Type -> Text
getDecoder  Type
TString    = Text
"Json.Decode.string"
getDecoder  Type
TInt       = Text
"Json.Decode.int"
getDecoder  Type
TDouble    = Text
"Json.Decode.float"
getDecoder  Type
TBool      = Text
"Json.Decode.bool"
getDecoder (TArray  Type
t) = Text
"Json.Decode.list (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
getDecoder Type
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
getDecoder (TLabel  Text
l) = Text -> Text
decoderIdent Text
l
getDecoder (TObj    Dict
o) = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error   [Char]
"getDecoder cannot handle complex object types!"
getDecoder (TUnion  Set Type
u) = case [Type]
nonNull of
                           []  -> Text
"Json.Decode.value"
                           [Type
x] -> Type -> Text
getDecoder Type
x
                           [Type]
_   -> (Text -> Text -> Text) -> [Text] -> Text
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
altDecoder ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Type -> Text) -> [Type] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Text
getDecoder [Type]
nonNull
  where
    nonNull :: [Type]
nonNull = Set Type -> [Type]
nonNullComponents Set Type
u
--error $ "getDecoder cannot yet handle union types:" <> show u

altDecoder :: a -> a -> a
altDecoder a
a a
b = a
"(Json.Decode.oneOf [Json.Decode.map Either.Left ("
              a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"), Json.Decode.map Either.Right ("
              a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
")])"
{-Json.Decode.Pipeline.decode Something
"Json.Decode.Pipeline " <>-}
                     

decoderIdent :: Text -> Text
decoderIdent Text
ident = Text
"decode" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalize (Text -> Text
normalizeTypeName Text
ident)
-- Contents example for wrapFromJSON:
-- " <$>
--"                           v .: "hexValue"  <*>
--"                           v .: "colorName\""

encoderIdent :: Text -> Text
encoderIdent Text
ident = Text
"encode" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalize (Text -> Text
normalizeTypeName Text
ident)

-- | Make Encoder declaration, given identifier (object name in Haskell) and mapping of its keys
-- from JSON to Haskell identifiers in the same order as in declaration
makeEncoder :: Text -> [MappedKey] -> Text
makeEncoder :: Text -> [MappedKey] -> Text
makeEncoder Text
identifier [MappedKey]
contents =
    [Text] -> Text
Text.unlines [
        [Text] -> Text
Text.unwords [Text -> Text
encoderIdent Text
identifier, Text
":", Text
identifier, Text
"->", Text
"Json.Encode.Value"]
      , Text -> Text
encoderIdent Text
identifier Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" record ="
      , Text
"    Json.Encode.object ["
      , Text
"        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
joinWith Text
"\n      , " (MappedKey -> Text
forall {b} {c} {e}. (Text, b, c, Type, e) -> Text
makeEncoder (MappedKey -> Text) -> [MappedKey] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MappedKey]
contents))
      , Text
"    ]"
      ]
  where
    makeEncoder :: (Text, b, c, Type, e) -> Text
makeEncoder (Text
jsonId, b
haskellId, c
_typeText, Type
ty, e
_nullable) = [Text] -> Text
Text.concat [
            Text
"(", Text -> Text
forall a. Show a => a -> Text
tShow Text
jsonId, Text
", (", Type -> Text
getEncoder Type
ty, Text
") record.", Text -> Text -> Text
normalizeFieldName Text
identifier Text
jsonId, Text
")"
        ]
    --"answers",  Json.Encode.list <| List.map encodeAnswer <| record.answers
    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

getEncoder :: Type -> Text
getEncoder :: Type -> Text
getEncoder  Type
TString   = Text
"Json.Encode.string"
getEncoder  Type
TDouble   = Text
"Json.Encode.float"
getEncoder  Type
TInt      = Text
"Json.Encode.int"
getEncoder  Type
TBool     = Text
"Json.Encode.bool"
getEncoder  Type
TNull     = Text
"identity"
getEncoder (TLabel Text
l) = Text -> Text
encoderIdent Text
l
getEncoder (TArray Type
e) = Text
"Json.Encode.list << List.map (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
getEncoder Type
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
getEncoder (TObj   Dict
o) = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Seeing direct object encoder: "         [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Dict -> [Char]
forall a. Show a => a -> [Char]
show Dict
o
getEncoder (TUnion Set Type
u) = case [Type]
nonNull of
                           []  -> Text
"identity"
                           [Type
x] -> Type -> Text
getDecoder Type
x
                           [Type]
_   -> (Text -> Text -> Text) -> [Text] -> Text
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
altEncoder ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Type -> Text) -> [Type] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Text
getEncoder [Type]
nonNull
  where
    nonNull :: [Type]
nonNull = Set Type -> [Type]
nonNullComponents Set Type
u

altEncoder :: a -> a -> a
altEncoder a
a a
b = a
"Either.unpack (" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
") (" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
")"

-- Contents example for wrapToJSON
--"hexValue"  .= hexValue
--                                        ,"colorName" .= colorName]
-- | Join text with other as separator.
joinWith :: Text -> [Text] -> Text
joinWith :: Text -> [Text] -> Text
joinWith Text
_      []            = Text
""
joinWith Text
joiner (Text
aFirst:[Text]
rest) = Text
aFirst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.concat ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
joiner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
rest)

-- | 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
v, 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
makeDecoder Text
identifier              [MappedKey]
attrs
                                                    ,Text
""
                                                    ,Text -> [MappedKey] -> Text
makeEncoder 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, Type, Bool) -> Text
    fieldDecl :: MappedKey -> Text
fieldDecl (Text
_jsonName, Text
haskellName, Text
fType, Type
_type, Bool
_nullable) = [Text] -> Text
Text.concat [
                                                                    Text
"    ", 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
"type", Text
"alias", Text
"exposing", 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

nonNullComponents :: Set Type -> [Type]
nonNullComponents = Set Type -> [Type]
forall a. Set a -> [a]
Set.toList (Set Type -> [Type])
-> (Set Type -> Set Type) -> Set Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
/=)
-- | 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
"String"
formatType  Type
TDouble                          = Text -> DeclM Text
forall a. a -> StateT DeclState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Float"
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
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. HasCallStack => [a] -> a
head [Type]
nonNull
                                                          Int
_ -> (Text -> Text -> Text) -> [Text] -> Text
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Text -> Text -> Text
join ([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]
nonNullComponents 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
    join :: Text -> Text -> Text
join Text
fAlt Text
fOthers = [Text] -> Text
Text.concat [Text
"Either (", Text
fAlt, Text
") (", Text
fOthers, Text
")"]
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
"List (", 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
"Json.Decode.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]

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
s  = 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
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) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
s
  where
    ifEmpty :: p -> p -> p
ifEmpty p
x p
""       = p
x
    ifEmpty p
_ p
nonEmpty = p
nonEmpty
    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@(HasCallStack => 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

-- | Remaps type labels according to a `Map`.
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