{-# LANGUAGE OverloadedStrings #-}

module Elminator.Lib
  ( TypeDescriptor(..)
  , PolyConfig(..)
  , GenOption(..)
  , GenM
  , Decoder(..)
  , ConName
  , ConTag
  , ContentDecoder(..)
  , FieldName
  , FieldTag
  , ConstructorDescriptor(..)
  , Constructors
  , toTypeDescriptor
  , collectExtRefs
  , typeDescriptorToDecoder
  , renderTypeVar
  , Builder
  , ElmVersion(..)
  , renderTypeHead
  , renderType
  , ReifyInfo(..)
  , nameToText
  , wrapInPara
  ) where

import Control.Monad.Reader as R
import Control.Monad.State.Lazy
import Control.Monad.Writer as W
import Data.Aeson
import qualified Data.List as DL
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.Map.Strict as DMS
import Data.Maybe
import Data.Text as T hiding (foldr)
import Elminator.Generics.Simple
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Monad (zipWithM)

data ContentDecoder
  = CDRecord [(FieldName, FieldTag, TypeDescriptor)]
  | CDRecordRaw (FieldName, FieldTag, TypeDescriptor)
  | CDList [TypeDescriptor]
  | CDRaw TypeDescriptor
  | CDEmpty
  deriving (Int -> ContentDecoder -> ShowS
[ContentDecoder] -> ShowS
ContentDecoder -> [Char]
(Int -> ContentDecoder -> ShowS)
-> (ContentDecoder -> [Char])
-> ([ContentDecoder] -> ShowS)
-> Show ContentDecoder
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContentDecoder -> ShowS
showsPrec :: Int -> ContentDecoder -> ShowS
$cshow :: ContentDecoder -> [Char]
show :: ContentDecoder -> [Char]
$cshowList :: [ContentDecoder] -> ShowS
showList :: [ContentDecoder] -> ShowS
Show)

type ConName = Text

type ConTag = Text

type FieldName = Text

type FieldTag = Text

-- Structure that we use to specify
-- both encoders and decoders.
data Decoder
  = DUnderConKey [(ConName, ConTag, ContentDecoder)]
  | DTagged Text Text [(ConName, ConTag, ContentDecoder)]
  | DTwoElement [(ConName, ConTag, ContentDecoder)]
  | DUntagged [(ConName, ContentDecoder)]
  deriving (Int -> Decoder -> ShowS
[Decoder] -> ShowS
Decoder -> [Char]
(Int -> Decoder -> ShowS)
-> (Decoder -> [Char]) -> ([Decoder] -> ShowS) -> Show Decoder
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Decoder -> ShowS
showsPrec :: Int -> Decoder -> ShowS
$cshow :: Decoder -> [Char]
show :: Decoder -> [Char]
$cshowList :: [Decoder] -> ShowS
showList :: [Decoder] -> ShowS
Show)

type GenM = WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q)

-- | Decides wether the type definition will be polymorphic.
data PolyConfig
  = Mono
  | Poly
  deriving (Int -> PolyConfig -> ShowS
[PolyConfig] -> ShowS
PolyConfig -> [Char]
(Int -> PolyConfig -> ShowS)
-> (PolyConfig -> [Char])
-> ([PolyConfig] -> ShowS)
-> Show PolyConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PolyConfig -> ShowS
showsPrec :: Int -> PolyConfig -> ShowS
$cshow :: PolyConfig -> [Char]
show :: PolyConfig -> [Char]
$cshowList :: [PolyConfig] -> ShowS
showList :: [PolyConfig] -> ShowS
Show)

-- | Decides which among type definiton, encoder and decoder
-- will be included for a type. The poly config value decides
-- wether the included type definition will be polymorphic.
data GenOption
  = Definiton PolyConfig
  | EncoderDecoder
  | Everything PolyConfig
  deriving (Int -> GenOption -> ShowS
[GenOption] -> ShowS
GenOption -> [Char]
(Int -> GenOption -> ShowS)
-> (GenOption -> [Char])
-> ([GenOption] -> ShowS)
-> Show GenOption
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenOption -> ShowS
showsPrec :: Int -> GenOption -> ShowS
$cshow :: GenOption -> [Char]
show :: GenOption -> [Char]
$cshowList :: [GenOption] -> ShowS
showList :: [GenOption] -> ShowS
Show)

type GenConfig = DMS.Map MData ([GenOption], HType)

type Builder = State GenConfig ()

-- | Specify Elm version to generate code for
data ElmVersion
  = Elm0p18
  | Elm0p19

-- | Contains the type arguments of a type
-- | with info regarding if they are Phantom
-- | and the list of constructors from TH reifiy
data ReifyInfo =
  ReifyInfo [TypeVar] [Con]
  deriving (Int -> ReifyInfo -> ShowS
[ReifyInfo] -> ShowS
ReifyInfo -> [Char]
(Int -> ReifyInfo -> ShowS)
-> (ReifyInfo -> [Char])
-> ([ReifyInfo] -> ShowS)
-> Show ReifyInfo
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReifyInfo -> ShowS
showsPrec :: Int -> ReifyInfo -> ShowS
$cshow :: ReifyInfo -> [Char]
show :: ReifyInfo -> [Char]
$cshowList :: [ReifyInfo] -> ShowS
showList :: [ReifyInfo] -> ShowS
Show, ReifyInfo -> ReifyInfo -> Bool
(ReifyInfo -> ReifyInfo -> Bool)
-> (ReifyInfo -> ReifyInfo -> Bool) -> Eq ReifyInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReifyInfo -> ReifyInfo -> Bool
== :: ReifyInfo -> ReifyInfo -> Bool
$c/= :: ReifyInfo -> ReifyInfo -> Bool
/= :: ReifyInfo -> ReifyInfo -> Bool
Eq)

-- | Except for the reified info from TH, this type
-- holds more or less same info as HType
-- but it is arranged in a bit more accessable way for the
-- code that uses this information.
data TypeDescriptor
  = TEmpty MData [TypeVar] [TypeDescriptor]
  | TOccupied MData ReifyInfo [TypeDescriptor] Constructors
  | TList TypeDescriptor
  | TMaybe TypeDescriptor
  | TTuple [TypeDescriptor]
  | TPrimitive MData
  | TRecusrive MData
  | TExternal (ExInfo TypeDescriptor)
  | TVar Name
  deriving (Int -> TypeDescriptor -> ShowS
[TypeDescriptor] -> ShowS
TypeDescriptor -> [Char]
(Int -> TypeDescriptor -> ShowS)
-> (TypeDescriptor -> [Char])
-> ([TypeDescriptor] -> ShowS)
-> Show TypeDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeDescriptor -> ShowS
showsPrec :: Int -> TypeDescriptor -> ShowS
$cshow :: TypeDescriptor -> [Char]
show :: TypeDescriptor -> [Char]
$cshowList :: [TypeDescriptor] -> ShowS
showList :: [TypeDescriptor] -> ShowS
Show)

type Constructors = NE.NonEmpty ConstructorDescriptor

data ConstructorDescriptor
  = RecordConstructor Text (NE.NonEmpty (Text, TypeDescriptor))
  | SimpleConstructor Text (NE.NonEmpty TypeDescriptor)
  | NullaryConstructor Text
  deriving (Int -> ConstructorDescriptor -> ShowS
[ConstructorDescriptor] -> ShowS
ConstructorDescriptor -> [Char]
(Int -> ConstructorDescriptor -> ShowS)
-> (ConstructorDescriptor -> [Char])
-> ([ConstructorDescriptor] -> ShowS)
-> Show ConstructorDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstructorDescriptor -> ShowS
showsPrec :: Int -> ConstructorDescriptor -> ShowS
$cshow :: ConstructorDescriptor -> [Char]
show :: ConstructorDescriptor -> [Char]
$cshowList :: [ConstructorDescriptor] -> ShowS
showList :: [ConstructorDescriptor] -> ShowS
Show)

getInfo :: Text -> GenM ([Name], [Con])
getInfo :: Text -> GenM ([Name], [Con])
getInfo Text
tnString =
  ReaderT (ElmVersion, GenConfig) Q ([Name], [Con])
-> GenM ([Name], [Con])
forall (m :: * -> *) a. Monad m => m a -> WriterT [ExItem] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
W.lift (ReaderT (ElmVersion, GenConfig) Q ([Name], [Con])
 -> GenM ([Name], [Con]))
-> ReaderT (ElmVersion, GenConfig) Q ([Name], [Con])
-> GenM ([Name], [Con])
forall a b. (a -> b) -> a -> b
$
  Q ([Name], [Con])
-> ReaderT (ElmVersion, GenConfig) Q ([Name], [Con])
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (ElmVersion, GenConfig) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
R.lift (Q ([Name], [Con])
 -> ReaderT (ElmVersion, GenConfig) Q ([Name], [Con]))
-> Q ([Name], [Con])
-> ReaderT (ElmVersion, GenConfig) Q ([Name], [Con])
forall a b. (a -> b) -> a -> b
$ do
    Maybe Name
mName <- [Char] -> Q (Maybe Name)
lookupTypeName ([Char] -> Q (Maybe Name)) -> [Char] -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
tnString
    case Maybe Name
mName of
      Just Name
tName -> do
        Info
info <- Name -> Q Info
reify Name
tName
        ([Name], [Con]) -> Q ([Name], [Con])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Info -> [Name]
getTypeArgs Info
info, Info -> [Con]
getConstructors Info
info)
      Maybe Name
Nothing ->
        [Char] -> Q ([Name], [Con])
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q ([Name], [Con])) -> [Char] -> Q ([Name], [Con])
forall a b. (a -> b) -> a -> b
$
        Text -> [Char]
unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Cannot find type with name ", Text
tnString, Text
" in scope"]

toTypeDescriptor :: HType -> GenM TypeDescriptor
toTypeDescriptor :: HType -> GenM TypeDescriptor
toTypeDescriptor (HUDef UDefData
udata) =
  case UDefData
udata of
    UDefData mdata :: MData
mdata@(MData Text
tnString Text
_ Text
_) [HType]
targs [HConstructor]
hcons -> do
      [TypeDescriptor]
tdArgs <- (HType -> GenM TypeDescriptor)
-> [HType]
-> WriterT
     [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [TypeDescriptor]
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 HType -> GenM TypeDescriptor
toTypeDescriptor [HType]
targs
      case Text -> Maybe Int
isTuple Text
tnString of
        Just Int
_ -> TypeDescriptor -> GenM TypeDescriptor
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDescriptor -> GenM TypeDescriptor)
-> TypeDescriptor -> GenM TypeDescriptor
forall a b. (a -> b) -> a -> b
$ [TypeDescriptor] -> TypeDescriptor
TTuple [TypeDescriptor]
tdArgs
        Maybe Int
Nothing -> do
          ([Name]
tVars, [Con]
cnstrs) <- Text -> GenM ([Name], [Con])
getInfo Text
tnString
          case [HConstructor]
hcons of
            [] -> TypeDescriptor -> GenM TypeDescriptor
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDescriptor -> GenM TypeDescriptor)
-> TypeDescriptor -> GenM TypeDescriptor
forall a b. (a -> b) -> a -> b
$ MData -> [TypeVar] -> [TypeDescriptor] -> TypeDescriptor
TEmpty MData
mdata (Name -> TypeVar
Phantom (Name -> TypeVar) -> [Name] -> [TypeVar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tVars) [TypeDescriptor]
tdArgs
            (HConstructor
c:[HConstructor]
cs) -> do
              Constructors
rawCons <-
                do ConstructorDescriptor
h <- HConstructor -> GenM ConstructorDescriptor
mkTdConstructor HConstructor
c
                   [ConstructorDescriptor]
t <- (HConstructor -> GenM ConstructorDescriptor)
-> [HConstructor]
-> WriterT
     [ExItem]
     (ReaderT (ElmVersion, GenConfig) Q)
     [ConstructorDescriptor]
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 HConstructor -> GenM ConstructorDescriptor
mkTdConstructor [HConstructor]
cs
                   Constructors
-> WriterT
     [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Constructors
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constructors
 -> WriterT
      [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Constructors)
-> Constructors
-> WriterT
     [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Constructors
forall a b. (a -> b) -> a -> b
$ ConstructorDescriptor
h ConstructorDescriptor -> [ConstructorDescriptor] -> Constructors
forall a. a -> [a] -> NonEmpty a
:| [ConstructorDescriptor]
t
              let reifyInfo :: ReifyInfo
reifyInfo = [TypeVar] -> [Con] -> ReifyInfo
ReifyInfo ([Con] -> Name -> TypeVar
mkTypeArg [Con]
cnstrs (Name -> TypeVar) -> [Name] -> [TypeVar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tVars) [Con]
cnstrs
              TypeDescriptor -> GenM TypeDescriptor
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDescriptor -> GenM TypeDescriptor)
-> TypeDescriptor -> GenM TypeDescriptor
forall a b. (a -> b) -> a -> b
$ MData
-> ReifyInfo -> [TypeDescriptor] -> Constructors -> TypeDescriptor
TOccupied MData
mdata ReifyInfo
reifyInfo [TypeDescriptor]
tdArgs Constructors
rawCons
toTypeDescriptor (HPrimitive MData
md) = TypeDescriptor -> GenM TypeDescriptor
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDescriptor -> GenM TypeDescriptor)
-> TypeDescriptor -> GenM TypeDescriptor
forall a b. (a -> b) -> a -> b
$ MData -> TypeDescriptor
TPrimitive MData
md
toTypeDescriptor (HList HType
ht) = TypeDescriptor -> TypeDescriptor
TList (TypeDescriptor -> TypeDescriptor)
-> GenM TypeDescriptor -> GenM TypeDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HType -> GenM TypeDescriptor
toTypeDescriptor HType
ht
toTypeDescriptor (HMaybe HType
ht) = TypeDescriptor -> TypeDescriptor
TMaybe (TypeDescriptor -> TypeDescriptor)
-> GenM TypeDescriptor -> GenM TypeDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HType -> GenM TypeDescriptor
toTypeDescriptor HType
ht
toTypeDescriptor (HRecursive MData
m) = TypeDescriptor -> GenM TypeDescriptor
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDescriptor -> GenM TypeDescriptor)
-> TypeDescriptor -> GenM TypeDescriptor
forall a b. (a -> b) -> a -> b
$ MData -> TypeDescriptor
TRecusrive MData
m
toTypeDescriptor (HExternal ExInfo HType
e) = do
  [TypeDescriptor]
tds <- (HType -> GenM TypeDescriptor)
-> [HType]
-> WriterT
     [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [TypeDescriptor]
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 HType -> GenM TypeDescriptor
toTypeDescriptor ([HType]
 -> WriterT
      [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [TypeDescriptor])
-> [HType]
-> WriterT
     [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [TypeDescriptor]
forall a b. (a -> b) -> a -> b
$ ExInfo HType -> [HType]
forall a. ExInfo a -> [a]
exTypeArgs ExInfo HType
e
  TypeDescriptor -> GenM TypeDescriptor
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDescriptor -> GenM TypeDescriptor)
-> TypeDescriptor -> GenM TypeDescriptor
forall a b. (a -> b) -> a -> b
$ ExInfo TypeDescriptor -> TypeDescriptor
TExternal ExInfo HType
e {exTypeArgs = tds}

mkTdConstructor :: HConstructor -> GenM ConstructorDescriptor
mkTdConstructor :: HConstructor -> GenM ConstructorDescriptor
mkTdConstructor HConstructor
hc =
  case HConstructor
hc of
    HConstructor (CName Text
cname) [HField]
fields ->
      case [HField]
fields of
        [] -> ConstructorDescriptor -> GenM ConstructorDescriptor
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorDescriptor -> GenM ConstructorDescriptor)
-> ConstructorDescriptor -> GenM ConstructorDescriptor
forall a b. (a -> b) -> a -> b
$ Text -> ConstructorDescriptor
NullaryConstructor Text
cname
        hfields :: [HField]
hfields@(HField (Just Text
_) HType
_:[HField]
_) ->
          let mapFn :: HField -> GenM (Text, TypeDescriptor)
              mapFn :: HField -> GenM (Text, TypeDescriptor)
mapFn (HField Maybe Text
Nothing HType
_) = [Char] -> GenM (Text, TypeDescriptor)
forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected unnamed field"
              mapFn (HField (Just Text
n) HType
x) = do
                TypeDescriptor
td <- HType -> GenM TypeDescriptor
toTypeDescriptor HType
x
                (Text, TypeDescriptor) -> GenM (Text, TypeDescriptor)
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
n, TypeDescriptor
td)
           in do [(Text, TypeDescriptor)]
a <- (HField -> GenM (Text, TypeDescriptor))
-> [HField]
-> WriterT
     [ExItem]
     (ReaderT (ElmVersion, GenConfig) Q)
     [(Text, TypeDescriptor)]
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 HField -> GenM (Text, TypeDescriptor)
mapFn [HField]
hfields
                 ConstructorDescriptor -> GenM ConstructorDescriptor
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorDescriptor -> GenM ConstructorDescriptor)
-> ConstructorDescriptor -> GenM ConstructorDescriptor
forall a b. (a -> b) -> a -> b
$ Text -> NonEmpty (Text, TypeDescriptor) -> ConstructorDescriptor
RecordConstructor Text
cname (NonEmpty (Text, TypeDescriptor) -> ConstructorDescriptor)
-> NonEmpty (Text, TypeDescriptor) -> ConstructorDescriptor
forall a b. (a -> b) -> a -> b
$ [(Text, TypeDescriptor)] -> NonEmpty (Text, TypeDescriptor)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [(Text, TypeDescriptor)]
a
        hfields :: [HField]
hfields@(HField Maybe Text
_ HType
_:[HField]
_) ->
          let mapFn :: HField -> GenM TypeDescriptor
              mapFn :: HField -> GenM TypeDescriptor
mapFn (HField Maybe Text
_ HType
td) = HType -> GenM TypeDescriptor
toTypeDescriptor HType
td
           in do [TypeDescriptor]
a <- (HField -> GenM TypeDescriptor)
-> [HField]
-> WriterT
     [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [TypeDescriptor]
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 HField -> GenM TypeDescriptor
mapFn [HField]
hfields
                 ConstructorDescriptor -> GenM ConstructorDescriptor
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorDescriptor -> GenM ConstructorDescriptor)
-> ConstructorDescriptor -> GenM ConstructorDescriptor
forall a b. (a -> b) -> a -> b
$ Text -> NonEmpty TypeDescriptor -> ConstructorDescriptor
SimpleConstructor Text
cname (NonEmpty TypeDescriptor -> ConstructorDescriptor)
-> NonEmpty TypeDescriptor -> ConstructorDescriptor
forall a b. (a -> b) -> a -> b
$ [TypeDescriptor] -> NonEmpty TypeDescriptor
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [TypeDescriptor]
a

mkTypeArg :: [Con] -> Name -> TypeVar
mkTypeArg :: [Con] -> Name -> TypeVar
mkTypeArg [Con]
constrs Name
name =
  if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Con -> Bool
searchCon Name
name (Con -> Bool) -> [Con] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
constrs
    then Name -> TypeVar
Used Name
name
    else Name -> TypeVar
Phantom Name
name

searchCon :: Name -> Con -> Bool
searchCon :: Name -> Con -> Bool
searchCon Name
name Con
con = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
DL.or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Bool
searchType Name
name (Type -> Bool) -> [Type] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> [Type]
getConstructorFields Con
con
  where
    searchType :: Name -> Type -> Bool
    searchType :: Name -> Type -> Bool
searchType Name
name_ (VarT Name
n) = Name
name_ Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n
    searchType Name
name_ (AppT Type
t1 Type
t2) = Name -> Type -> Bool
searchType Name
name_ Type
t1 Bool -> Bool -> Bool
|| Name -> Type -> Bool
searchType Name
name_ Type
t2
    searchType Name
_ Type
_ = Bool
False

getConstructorFields :: Con -> [Type]
getConstructorFields :: Con -> [Type]
getConstructorFields Con
c =
  case Con
c of
    (NormalC Name
_ [BangType]
args) -> BangType -> Type
forall a b. (a, b) -> b
snd (BangType -> Type) -> [BangType] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BangType]
args
    (RecC Name
_ [VarBangType]
args) -> (\(Name
_, Bang
_, Type
x) -> Type
x) (VarBangType -> Type) -> [VarBangType] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
args
    Con
_ -> [Char] -> [Type]
forall a. HasCallStack => [Char] -> a
error [Char]
"Not implemented"

getConstructors :: Info -> [Con]
getConstructors :: Info -> [Con]
getConstructors Info
info =
  case Info
info of
    TyConI (DataD [] Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con]
c [DerivClause]
_) -> [Con]
c
    TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ Con
c [DerivClause]
_) -> [Con
c]
    Info
x -> [Char] -> [Con]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Con]) -> [Char] -> [Con]
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported type info" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Info -> [Char]
forall a. Show a => a -> [Char]
show Info
x

getTypeArgs :: Info -> [Name]
getTypeArgs :: Info -> [Name]
getTypeArgs Info
i =
  case Info
i of
    TyConI (DataD [Type]
_ Name
_ [TyVarBndr ()]
args Maybe Type
_ [Con]
_ [DerivClause]
_) -> TyVarBndr () -> Name
forall b. TyVarBndr b -> Name
mapFn (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
args
    TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
args Maybe Type
_ Con
_ [DerivClause]
_) -> TyVarBndr () -> Name
forall b. TyVarBndr b -> Name
mapFn (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
args
    Info
_ -> [Char] -> [Name]
forall a. HasCallStack => [Char] -> a
error [Char]
"Unimplemented"
  where
    mapFn :: TyVarBndr b -> Name
    mapFn :: forall b. TyVarBndr b -> Name
mapFn (PlainTV Name
n b
_) = Name
n
    mapFn (KindedTV Name
n b
_ Type
_) = Name
n

nameToText :: Name -> String
nameToText :: Name -> [Char]
nameToText (Name (OccName [Char]
a) NameFlavour
_) = [Char]
a

renderTypeHead :: TypeDescriptor -> Text
renderTypeHead :: TypeDescriptor -> Text
renderTypeHead TypeDescriptor
td =
  case TypeDescriptor
td of
    TEmpty MData
md [TypeVar]
_ [TypeDescriptor]
_ -> MData -> Text
_mTypeName MData
md
    TOccupied MData
md ReifyInfo
_ [TypeDescriptor]
_ Constructors
_ -> MData -> Text
_mTypeName MData
md
    TRecusrive MData
md -> MData -> Text
_mTypeName MData
md
    TypeDescriptor
x -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char]
"Unimplemented" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeDescriptor -> [Char]
forall a. Show a => a -> [Char]
show TypeDescriptor
x)

renderType :: TypeDescriptor -> Bool -> Bool -> GenM Text
renderType :: TypeDescriptor -> Bool -> Bool -> GenM Text
renderType TypeDescriptor
td Bool
includePara Bool
showPhantom = do
  Bool
hp <-
    case TypeDescriptor -> Maybe MData
getMd TypeDescriptor
td of
      Maybe MData
Nothing -> Bool -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Bool
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      Just MData
md -> MData -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Bool
hasPoly MData
md
  if Bool
hp
    then Text -> Text
wrapInParaConditionally (Text -> Text) -> GenM Text -> GenM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         case TypeDescriptor
td of
           TEmpty MData
md [TypeVar]
tvars [TypeDescriptor]
targs -> do
             [Text]
ta <- (TypeDescriptor -> TypeVar -> GenM Text)
-> [TypeDescriptor]
-> [TypeVar]
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [Text]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM TypeDescriptor -> TypeVar -> GenM Text
renderFn [TypeDescriptor]
targs [TypeVar]
tvars
             Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [MData -> Text
_mTypeName MData
md, Text
" ", Text -> [Text] -> Text
T.intercalate Text
" " [Text]
ta]
           TOccupied MData
md (ReifyInfo [TypeVar]
tvars [Con]
_) [TypeDescriptor]
targs Constructors
_ -> do
             [Text]
ta <- (TypeDescriptor -> TypeVar -> GenM Text)
-> [TypeDescriptor]
-> [TypeVar]
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [Text]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM TypeDescriptor -> TypeVar -> GenM Text
renderFn [TypeDescriptor]
targs [TypeVar]
tvars
             Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [MData -> Text
_mTypeName MData
md, Text
" ", Text -> [Text] -> Text
T.intercalate Text
" " [Text]
ta]
           TList TypeDescriptor
wtd -> do
             Text
a <- TypeDescriptor -> Bool -> Bool -> GenM Text
renderType TypeDescriptor
wtd Bool
True Bool
showPhantom
             Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"List ", Text
a, Text
""]
           TMaybe TypeDescriptor
wtd -> do
             Text
a <- TypeDescriptor -> Bool -> Bool -> GenM Text
renderType TypeDescriptor
wtd Bool
True Bool
showPhantom
             Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Maybe ", Text
a, Text
""]
           TTuple [TypeDescriptor]
tds -> do
             [Text]
ta <- (TypeDescriptor -> GenM Text)
-> [TypeDescriptor]
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [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 (\TypeDescriptor
x -> TypeDescriptor -> Bool -> Bool -> GenM Text
renderType TypeDescriptor
x Bool
False Bool
showPhantom) [TypeDescriptor]
tds
             Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"(", Text -> [Text] -> Text
T.intercalate Text
", " [Text]
ta, Text
")"]
           TPrimitive MData
md -> Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ MData -> Text
_mTypeName MData
md
           TRecusrive MData
md -> Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ MData -> Text
_mTypeName MData
md
           TExternal ExInfo TypeDescriptor
ei -> do
             [Text]
ta <- (TypeDescriptor -> GenM Text)
-> [TypeDescriptor]
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [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 (\TypeDescriptor
x -> TypeDescriptor -> Bool -> Bool -> GenM Text
renderType TypeDescriptor
x Bool
True Bool
showPhantom) ([TypeDescriptor]
 -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [Text])
-> [TypeDescriptor]
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) [Text]
forall a b. (a -> b) -> a -> b
$ ExInfo TypeDescriptor -> [TypeDescriptor]
forall a. ExInfo a -> [a]
exTypeArgs ExInfo TypeDescriptor
ei
             Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [ExItem -> Text
forall a b. (a, b) -> b
snd (ExItem -> Text) -> ExItem -> Text
forall a b. (a -> b) -> a -> b
$ ExInfo TypeDescriptor -> ExItem
forall a. ExInfo a -> ExItem
exType ExInfo TypeDescriptor
ei, Text
" ", Text -> [Text] -> Text
T.intercalate Text
" " [Text]
ta]
           TVar Name
name -> Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameToText Name
name
    else Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ TypeDescriptor -> Text
renderTypeHead TypeDescriptor
td
  where
    wrapInParaConditionally :: Text -> Text
    wrapInParaConditionally :: Text -> Text
wrapInParaConditionally Text
tn =
      if Bool
includePara
        then case TypeDescriptor
td of
               TEmpty MData
_ [TypeVar]
_ [TypeDescriptor]
targs ->
                 if Bool -> Bool
not ([TypeDescriptor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
DL.null [TypeDescriptor]
targs)
                   then Text -> Text
wrapInPara Text
tn
                   else Text
tn
               TOccupied MData
_ ReifyInfo
_ [TypeDescriptor]
targs Constructors
_ ->
                 if Bool -> Bool
not ([TypeDescriptor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
DL.null [TypeDescriptor]
targs)
                   then Text -> Text
wrapInPara Text
tn
                   else Text
tn
               TList TypeDescriptor
_ -> Text -> Text
wrapInPara Text
tn
               TMaybe TypeDescriptor
_ -> Text -> Text
wrapInPara Text
tn
               TExternal ExInfo TypeDescriptor
ei ->
                 if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [TypeDescriptor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
DL.null (ExInfo TypeDescriptor -> [TypeDescriptor]
forall a. ExInfo a -> [a]
exTypeArgs ExInfo TypeDescriptor
ei)
                   then Text -> Text
wrapInPara Text
tn
                   else Text
tn
               TypeDescriptor
_ -> Text
tn
        else Text
tn
    renderFn :: TypeDescriptor -> TypeVar -> GenM Text
    renderFn :: TypeDescriptor -> TypeVar -> GenM Text
renderFn TypeDescriptor
tdr (Phantom Name
n) =
      if Bool
showPhantom
        then Text -> GenM Text
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenM Text) -> Text -> GenM Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameToText Name
n
        else TypeDescriptor -> TypeVar -> GenM Text
renderFn TypeDescriptor
tdr (Name -> TypeVar
Used Name
n)
    renderFn TypeDescriptor
tdr (Used Name
_) = TypeDescriptor -> Bool -> Bool -> GenM Text
renderType TypeDescriptor
tdr Bool
True Bool
showPhantom

wrapInPara :: Text -> Text
wrapInPara :: Text -> Text
wrapInPara Text
i = [Text] -> Text
T.concat [Text
"(", Text
i, Text
")"]

hasPoly :: MData -> GenM Bool
hasPoly :: MData -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Bool
hasPoly MData
tn = do
  (ElmVersion
_, GenConfig
x) <- WriterT
  [ExItem]
  (ReaderT (ElmVersion, GenConfig) Q)
  (ElmVersion, GenConfig)
forall r (m :: * -> *). MonadReader r m => m r
ask
  case MData -> GenConfig -> Maybe ([GenOption], HType)
forall k a. Ord k => k -> Map k a -> Maybe a
DMS.lookup MData
tn GenConfig
x of
    Just ([GenOption], HType)
b -> Bool -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Bool
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Bool)
-> Bool
-> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Bool
forall a b. (a -> b) -> a -> b
$ ([GenOption], HType) -> Bool
hasPoly' ([GenOption], HType)
b
    Maybe ([GenOption], HType)
Nothing -> Bool -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) Bool
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  where
    hasPoly' :: ([GenOption], HType) -> Bool
    hasPoly' :: ([GenOption], HType) -> Bool
hasPoly' ([GenOption]
cl, HType
_) = Maybe GenOption -> Bool
forall a. Maybe a -> Bool
isJust (Maybe GenOption -> Bool) -> Maybe GenOption -> Bool
forall a b. (a -> b) -> a -> b
$ (GenOption -> Bool) -> [GenOption] -> Maybe GenOption
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
DL.find GenOption -> Bool
fn [GenOption]
cl
      where
        fn :: GenOption -> Bool
        fn :: GenOption -> Bool
fn (Definiton PolyConfig
Poly) = Bool
True
        fn (Everything PolyConfig
Poly) = Bool
True
        fn GenOption
_ = Bool
False

renderTypeVar :: TypeVar -> Text
renderTypeVar :: TypeVar -> Text
renderTypeVar (Used Name
tv) = [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameToText Name
tv
renderTypeVar (Phantom Name
tv) = [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameToText Name
tv

typeDescriptorToDecoder :: Options -> TypeDescriptor -> Decoder
typeDescriptorToDecoder :: Options -> TypeDescriptor -> Decoder
typeDescriptorToDecoder Options
opts TypeDescriptor
td =
  case TypeDescriptor
td of
    TEmpty {} -> [Char] -> Decoder
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot make decoder for Empty type"
    TOccupied MData
_ ReifyInfo
_ [TypeDescriptor]
_ Constructors
cnstrs -> Constructors -> Options -> Decoder
gdConstructor Constructors
cnstrs Options
opts
    TypeDescriptor
_ -> [Char] -> Decoder
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot only make decoders for user defined types"

gdConstructor :: Constructors -> Options -> Decoder
gdConstructor :: Constructors -> Options -> Decoder
gdConstructor (ConstructorDescriptor
cd :| []) Options
opts =
  if Options -> Bool
tagSingleConstructors Options
opts
    then [ConstructorDescriptor] -> Options -> Decoder
gdTaggedWithConstructor [ConstructorDescriptor
cd] Options
opts
    else [(Text, ContentDecoder)] -> Decoder
DUntagged [(ConstructorDescriptor -> Text
getCName ConstructorDescriptor
cd, Bool -> ConstructorDescriptor -> Options -> ContentDecoder
mkContentDecoder Bool
True ConstructorDescriptor
cd Options
opts)]
gdConstructor Constructors
cds Options
opts = [ConstructorDescriptor] -> Options -> Decoder
gdTaggedWithConstructor (Constructors -> [ConstructorDescriptor]
forall a. NonEmpty a -> [a]
NE.toList Constructors
cds) Options
opts

gdTaggedWithConstructor :: [ConstructorDescriptor] -> Options -> Decoder
gdTaggedWithConstructor :: [ConstructorDescriptor] -> Options -> Decoder
gdTaggedWithConstructor [ConstructorDescriptor]
cds Options
opts =
  case Options -> SumEncoding
sumEncoding Options
opts of
    TaggedObject [Char]
tfn [Char]
cfn -> Text -> Text -> [(Text, Text, ContentDecoder)] -> Decoder
DTagged ([Char] -> Text
pack [Char]
tfn) ([Char] -> Text
pack [Char]
cfn) [(Text, Text, ContentDecoder)]
cdPair
    SumEncoding
ObjectWithSingleField -> [(Text, Text, ContentDecoder)] -> Decoder
DUnderConKey [(Text, Text, ContentDecoder)]
cdPair
    SumEncoding
TwoElemArray -> [(Text, Text, ContentDecoder)] -> Decoder
DTwoElement [(Text, Text, ContentDecoder)]
cdPair
    SumEncoding
UntaggedValue ->
      [(Text, ContentDecoder)] -> Decoder
DUntagged ([(Text, ContentDecoder)] -> Decoder)
-> [(Text, ContentDecoder)] -> Decoder
forall a b. (a -> b) -> a -> b
$ (\ConstructorDescriptor
cd -> (ConstructorDescriptor -> Text
getCName ConstructorDescriptor
cd, Bool -> ConstructorDescriptor -> Options -> ContentDecoder
mkContentDecoder Bool
True ConstructorDescriptor
cd Options
opts)) (ConstructorDescriptor -> (Text, ContentDecoder))
-> [ConstructorDescriptor] -> [(Text, ContentDecoder)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDescriptor]
cds
  where
    cdPair :: [(ConName, ConTag, ContentDecoder)]
    cdPair :: [(Text, Text, ContentDecoder)]
cdPair =
      (\ConstructorDescriptor
cd ->
         ( ConstructorDescriptor -> Text
getCName ConstructorDescriptor
cd
         , [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Options -> ShowS
constructorTagModifier Options
opts ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ ConstructorDescriptor -> Text
getCName ConstructorDescriptor
cd
         , Bool -> ConstructorDescriptor -> Options -> ContentDecoder
mkContentDecoder Bool
False ConstructorDescriptor
cd Options
opts)) (ConstructorDescriptor -> (Text, Text, ContentDecoder))
-> [ConstructorDescriptor] -> [(Text, Text, ContentDecoder)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      [ConstructorDescriptor]
cds

mkContentDecoder :: Bool -> ConstructorDescriptor -> Options -> ContentDecoder
mkContentDecoder :: Bool -> ConstructorDescriptor -> Options -> ContentDecoder
mkContentDecoder Bool
overrideTaggConf ConstructorDescriptor
cd Options
opts =
  case ConstructorDescriptor
cd of
    RecordConstructor Text
_cname ((Text, TypeDescriptor)
nf :| []) ->
      case (Bool
overrideTaggConf, Options -> SumEncoding
sumEncoding Options
opts) of
        (Bool
False, TaggedObject [Char]
_ [Char]
_) -> [(Text, Text, TypeDescriptor)] -> ContentDecoder
CDRecord [(Text, TypeDescriptor) -> (Text, Text, TypeDescriptor)
modifyFieldLabel (Text, TypeDescriptor)
nf]
        (Bool, SumEncoding)
_ ->
          if Options -> Bool
unwrapUnaryRecords Options
opts
            then (Text, Text, TypeDescriptor) -> ContentDecoder
CDRecordRaw ((Text, Text, TypeDescriptor) -> ContentDecoder)
-> (Text, Text, TypeDescriptor) -> ContentDecoder
forall a b. (a -> b) -> a -> b
$ (Text, TypeDescriptor) -> (Text, Text, TypeDescriptor)
modifyFieldLabel (Text, TypeDescriptor)
nf
            else [(Text, Text, TypeDescriptor)] -> ContentDecoder
CDRecord [(Text, TypeDescriptor) -> (Text, Text, TypeDescriptor)
modifyFieldLabel (Text, TypeDescriptor)
nf]
    RecordConstructor Text
_cname NonEmpty (Text, TypeDescriptor)
nf ->
      [(Text, Text, TypeDescriptor)] -> ContentDecoder
CDRecord ([(Text, Text, TypeDescriptor)] -> ContentDecoder)
-> [(Text, Text, TypeDescriptor)] -> ContentDecoder
forall a b. (a -> b) -> a -> b
$ NonEmpty (Text, Text, TypeDescriptor)
-> [(Text, Text, TypeDescriptor)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (Text, Text, TypeDescriptor)
 -> [(Text, Text, TypeDescriptor)])
-> NonEmpty (Text, Text, TypeDescriptor)
-> [(Text, Text, TypeDescriptor)]
forall a b. (a -> b) -> a -> b
$ ((Text, TypeDescriptor) -> (Text, Text, TypeDescriptor))
-> NonEmpty (Text, TypeDescriptor)
-> NonEmpty (Text, Text, TypeDescriptor)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (Text, TypeDescriptor) -> (Text, Text, TypeDescriptor)
modifyFieldLabel NonEmpty (Text, TypeDescriptor)
nf
    SimpleConstructor Text
_cname (TypeDescriptor
f :| []) -> TypeDescriptor -> ContentDecoder
CDRaw TypeDescriptor
f
    SimpleConstructor Text
_cname NonEmpty TypeDescriptor
f -> [TypeDescriptor] -> ContentDecoder
CDList ([TypeDescriptor] -> ContentDecoder)
-> [TypeDescriptor] -> ContentDecoder
forall a b. (a -> b) -> a -> b
$ NonEmpty TypeDescriptor -> [TypeDescriptor]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty TypeDescriptor
f
    NullaryConstructor Text
_ -> ContentDecoder
CDEmpty
  where
    modifyFieldLabel ::
         (Text, TypeDescriptor) -> (FieldName, FieldTag, TypeDescriptor)
    modifyFieldLabel :: (Text, TypeDescriptor) -> (Text, Text, TypeDescriptor)
modifyFieldLabel (Text
a, TypeDescriptor
b) = (Text
a, [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Options -> ShowS
fieldLabelModifier Options
opts ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
a, TypeDescriptor
b)

getCName :: ConstructorDescriptor -> Text
getCName :: ConstructorDescriptor -> Text
getCName (RecordConstructor Text
x NonEmpty (Text, TypeDescriptor)
_) = Text
x
getCName (SimpleConstructor Text
x NonEmpty TypeDescriptor
_) = Text
x
getCName (NullaryConstructor Text
x) = Text
x

collectExtRefs :: TypeDescriptor -> GenM ()
collectExtRefs :: TypeDescriptor -> GenM ()
collectExtRefs (TExternal (ExInfo ExItem
ei (Just ExItem
en) (Just ExItem
de) [TypeDescriptor]
_)) = [ExItem] -> GenM ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ExItem
ei, ExItem
en, ExItem
de]
collectExtRefs (TExternal (ExInfo ExItem
ei Maybe ExItem
_ Maybe ExItem
_ [TypeDescriptor]
_)) = [ExItem] -> GenM ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ExItem
ei]
collectExtRefs (TEmpty MData
_ [TypeVar]
_ [TypeDescriptor]
targs) = (TypeDescriptor -> GenM ()) -> [TypeDescriptor] -> GenM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeDescriptor -> GenM ()
collectExtRefs [TypeDescriptor]
targs
collectExtRefs (TOccupied MData
_ ReifyInfo
_ [TypeDescriptor]
_ Constructors
cons_) =
  (TypeDescriptor -> GenM ()) -> [TypeDescriptor] -> GenM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeDescriptor -> GenM ()
collectExtRefs ([TypeDescriptor] -> GenM ()) -> [TypeDescriptor] -> GenM ()
forall a b. (a -> b) -> a -> b
$ Constructors -> [TypeDescriptor]
getConstructorsFields Constructors
cons_
collectExtRefs (TList TypeDescriptor
td) = TypeDescriptor -> GenM ()
collectExtRefs TypeDescriptor
td
collectExtRefs (TMaybe TypeDescriptor
td) = TypeDescriptor -> GenM ()
collectExtRefs TypeDescriptor
td
collectExtRefs (TPrimitive MData
_) = () -> GenM ()
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
collectExtRefs (TRecusrive MData
_) = () -> GenM ()
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
collectExtRefs TypeDescriptor
_ = () -> GenM ()
forall a.
a -> WriterT [ExItem] (ReaderT (ElmVersion, GenConfig) Q) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

getConstructorsFields :: Constructors -> [TypeDescriptor]
getConstructorsFields :: Constructors -> [TypeDescriptor]
getConstructorsFields Constructors
nec =
  [[TypeDescriptor]] -> [TypeDescriptor]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
DL.concat ([[TypeDescriptor]] -> [TypeDescriptor])
-> [[TypeDescriptor]] -> [TypeDescriptor]
forall a b. (a -> b) -> a -> b
$ NonEmpty [TypeDescriptor] -> [[TypeDescriptor]]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty [TypeDescriptor] -> [[TypeDescriptor]])
-> NonEmpty [TypeDescriptor] -> [[TypeDescriptor]]
forall a b. (a -> b) -> a -> b
$ (ConstructorDescriptor -> [TypeDescriptor])
-> Constructors -> NonEmpty [TypeDescriptor]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ConstructorDescriptor -> [TypeDescriptor]
getConstructorFields_ Constructors
nec

getConstructorFields_ :: ConstructorDescriptor -> [TypeDescriptor]
getConstructorFields_ :: ConstructorDescriptor -> [TypeDescriptor]
getConstructorFields_ (RecordConstructor Text
_ NonEmpty (Text, TypeDescriptor)
nef) = (Text, TypeDescriptor) -> TypeDescriptor
forall a b. (a, b) -> b
snd ((Text, TypeDescriptor) -> TypeDescriptor)
-> [(Text, TypeDescriptor)] -> [TypeDescriptor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Text, TypeDescriptor) -> [(Text, TypeDescriptor)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Text, TypeDescriptor)
nef
getConstructorFields_ (SimpleConstructor Text
_ NonEmpty TypeDescriptor
f) = NonEmpty TypeDescriptor -> [TypeDescriptor]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty TypeDescriptor
f
getConstructorFields_ (NullaryConstructor Text
_) = []

getMd :: TypeDescriptor -> Maybe MData
getMd :: TypeDescriptor -> Maybe MData
getMd TypeDescriptor
td =
  case TypeDescriptor
td of
    TEmpty MData
md [TypeVar]
_ [TypeDescriptor]
_ -> MData -> Maybe MData
forall a. a -> Maybe a
Just MData
md
    TOccupied MData
md ReifyInfo
_ [TypeDescriptor]
_ Constructors
_ -> MData -> Maybe MData
forall a. a -> Maybe a
Just MData
md
    TPrimitive MData
md -> MData -> Maybe MData
forall a. a -> Maybe a
Just MData
md
    TRecusrive MData
md -> MData -> Maybe MData
forall a. a -> Maybe a
Just MData
md
    TypeDescriptor
_ -> Maybe MData
forall a. Maybe a
Nothing