{-# 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.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           Data.Aeson.AutoType.Type
import           Data.Aeson.AutoType.Extract
import           Data.Aeson.AutoType.Split
import           Data.Aeson.AutoType.Format
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 alias ", 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, "  }"]
                                            --,"\nderiveJSON defaultOptions ''" `Text.append` identifier]
  where
    header :: Text
header = [Text] -> Text
Text.concat ["type alias ", 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, 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 identifier :: Text
identifier contents :: [MappedKey]
contents =
  [Text] -> Text
Text.unlines [
      [Text] -> Text
Text.concat  [Text
decodeIdentifier, " : Json.Decode.Decoder ", Text
identifier]
    , [Text] -> Text
Text.concat  [Text
decodeIdentifier, " ="]
    , [Text] -> Text
Text.unwords ["    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 identifier :: p
identifier (jsonId :: Text
jsonId, _, _, ty :: Type
ty, isOptional :: Bool
isOptional) = [Text] -> Text
Text.unwords [
          "  |>"
        , if Bool
isOptional
             then "Json.Decode.Pipeline.optional"
             else "Json.Decode.Pipeline.required"
        , [Text] -> Text
Text.concat ["\"", Text
jsonId, "\""]
        , "(" 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
<> ")"] -- quote

getDecoder :: Type -> Text
getDecoder  TString    = "Json.Decode.string"
getDecoder  TInt       = "Json.Decode.int"
getDecoder  TDouble    = "Json.Decode.float"
getDecoder  TBool      = "Json.Decode.bool"
getDecoder (TArray  t :: Type
t) = "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
<> ")"
getDecoder (TLabel  l :: Text
l) = Text -> Text
decoderIdent Text
l
getDecoder (TObj    o :: Dict
o) = String -> Text
forall a. HasCallStack => String -> a
error   "getDecoder cannot handle complex object types!"
getDecoder (TUnion  u :: Set Type
u) = case [Type]
nonNull of
                           []  -> "Json.Decode.value"
                           [x :: Type
x] -> Type -> Text
getDecoder Type
x
                           _   -> (Text -> Text -> Text) -> [Text] -> Text
forall a. (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
b = "(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
<> "), 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
<> ")])"
{-Json.Decode.Pipeline.decode Something
"Json.Decode.Pipeline " <>-}
                     

decoderIdent :: Text -> Text
decoderIdent ident :: Text
ident = "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 ident :: Text
ident = "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 identifier :: Text
identifier contents :: [MappedKey]
contents =
    [Text] -> Text
Text.unlines [
        [Text] -> Text
Text.unwords [Text -> Text
encoderIdent Text
identifier, ":", Text
identifier, "->", "Json.Encode.Value"]
      , Text -> Text
encoderIdent Text
identifier Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " record ="
      , "    Json.Encode.object ["
      , "        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
joinWith "\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))
      , "    ]"
      ]
  where
    makeEncoder :: (Text, b, c, Type, e) -> Text
makeEncoder (jsonId :: Text
jsonId, haskellId :: b
haskellId, _typeText :: c
_typeText, ty :: Type
ty, _nullable :: e
_nullable) = [Text] -> Text
Text.concat [
            "(", Text -> Text
forall a. Show a => a -> Text
tShow Text
jsonId, ", (", Type -> Text
getEncoder Type
ty, ") record.", Text -> Text -> Text
normalizeFieldName Text
identifier Text
jsonId, ")"
        ]
    --"answers",  Json.Encode.list <| List.map encodeAnswer <| record.answers
    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

getEncoder :: Type -> Text
getEncoder :: Type -> Text
getEncoder  TString   = "Json.Encode.string"
getEncoder  TDouble   = "Json.Encode.float"
getEncoder  TInt      = "Json.Encode.int"
getEncoder  TBool     = "Json.Encode.bool"
getEncoder  TNull     = "identity"
getEncoder (TLabel l :: Text
l) = Text -> Text
encoderIdent Text
l
getEncoder (TArray e :: Type
e) = "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
<> ")"
getEncoder (TObj   o :: Dict
o) = String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ "Seeing direct object encoder: "         String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Dict -> String
forall a. Show a => a -> String
show Dict
o
getEncoder (TUnion u :: Set Type
u) = case [Type]
nonNull of
                           []  -> "identity"
                           [x :: Type
x] -> Type -> Text
getDecoder Type
x
                           _   -> (Text -> Text -> Text) -> [Text] -> Text
forall a. (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
b = "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
forall a. Semigroup a => a -> a -> a
<> a
b a -> a -> a
forall a. Semigroup 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 _      []            = ""
joinWith joiner :: Text
joiner (aFirst :: Text
aFirst:rest :: [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 (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
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 -> [MappedKey] -> Text
makeDecoder Text
identifier              [MappedKey]
attrs
                                                    ,""
                                                    ,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 (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, Type, Bool) -> Text
    fieldDecl :: MappedKey -> Text
fieldDecl (_jsonName :: Text
_jsonName, haskellName :: Text
haskellName, fType :: Text
fType, _type :: Type
_type, _nullable :: Bool
_nullable) = [Text] -> Text
Text.concat [
                                                                    "    ", 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 ["type", "alias", "exposing", "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

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  TString                          = Text -> DeclM Text
forall (m :: * -> *) a. Monad m => a -> m a
return "String"
formatType  TDouble                          = Text -> DeclM Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Float"
formatType  TInt                             = Text -> DeclM Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Int"
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] -> Text
forall a. (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)
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   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
    join :: Text -> Text -> Text
join fAlt :: Text
fAlt fOthers :: Text
fOthers = [Text] -> Text
Text.concat ["Either (", Text
fAlt, ") (", Text
fOthers, ")"]
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 ["List (", 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 = "Json.Decode.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]

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 s :: Text
s  = 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) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
s
  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

-- | Remaps type labels according to a `Map`.
remapLabels :: Map Text Text -> Type -> Type
remapLabels :: Map Text Text -> Type -> Type
remapLabels ls :: Map Text Text
ls (TObj   o :: 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 ls :: Map Text Text
ls (TArray t :: 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 ls :: Map Text Text
ls (TUnion u :: 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 ls :: Map Text Text
ls (TLabel l :: 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 _  other :: Type
other      = Type
other