{-# 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

data ContentDecoder
  = CDRecord [(FieldName, FieldTag, TypeDescriptor)]
  | CDRecordRaw (FieldName, FieldTag, TypeDescriptor)
  | CDList [TypeDescriptor]
  | CDRaw TypeDescriptor
  | CDEmpty
  deriving (Int -> ContentDecoder -> ShowS
[ContentDecoder] -> ShowS
ContentDecoder -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ContentDecoder] -> ShowS
$cshowList :: [ContentDecoder] -> ShowS
show :: ContentDecoder -> [Char]
$cshow :: ContentDecoder -> [Char]
showsPrec :: Int -> ContentDecoder -> ShowS
$cshowsPrec :: Int -> 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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Decoder] -> ShowS
$cshowList :: [Decoder] -> ShowS
show :: Decoder -> [Char]
$cshow :: Decoder -> [Char]
showsPrec :: Int -> Decoder -> ShowS
$cshowsPrec :: Int -> 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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PolyConfig] -> ShowS
$cshowList :: [PolyConfig] -> ShowS
show :: PolyConfig -> [Char]
$cshow :: PolyConfig -> [Char]
showsPrec :: Int -> PolyConfig -> ShowS
$cshowsPrec :: Int -> 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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [GenOption] -> ShowS
$cshowList :: [GenOption] -> ShowS
show :: GenOption -> [Char]
$cshow :: GenOption -> [Char]
showsPrec :: Int -> GenOption -> ShowS
$cshowsPrec :: Int -> 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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ReifyInfo] -> ShowS
$cshowList :: [ReifyInfo] -> ShowS
show :: ReifyInfo -> [Char]
$cshow :: ReifyInfo -> [Char]
showsPrec :: Int -> ReifyInfo -> ShowS
$cshowsPrec :: Int -> ReifyInfo -> ShowS
Show, ReifyInfo -> ReifyInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReifyInfo -> ReifyInfo -> Bool
$c/= :: ReifyInfo -> ReifyInfo -> Bool
== :: ReifyInfo -> ReifyInfo -> Bool
$c== :: 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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TypeDescriptor] -> ShowS
$cshowList :: [TypeDescriptor] -> ShowS
show :: TypeDescriptor -> [Char]
$cshow :: TypeDescriptor -> [Char]
showsPrec :: Int -> TypeDescriptor -> ShowS
$cshowsPrec :: Int -> 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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ConstructorDescriptor] -> ShowS
$cshowList :: [ConstructorDescriptor] -> ShowS
show :: ConstructorDescriptor -> [Char]
$cshow :: ConstructorDescriptor -> [Char]
showsPrec :: Int -> ConstructorDescriptor -> ShowS
$cshowsPrec :: Int -> ConstructorDescriptor -> ShowS
Show)

getInfo :: Text -> GenM ([Name], [Con])
getInfo :: Text -> GenM ([Name], [Con])
getInfo Text
tnString =
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
W.lift forall a b. (a -> b) -> a -> b
$
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
R.lift forall a b. (a -> b) -> a -> b
$ do
    Maybe Name
mName <- [Char] -> Q (Maybe Name)
lookupTypeName 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
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Info -> [Name]
getTypeArgs Info
info, Info -> [Con]
getConstructors Info
info)
      Maybe Name
Nothing ->
        forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
        Text -> [Char]
unpack 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HType -> GenM TypeDescriptor
toTypeDescriptor [HType]
targs
      case Text -> Maybe Int
isTuple Text
tnString of
        Just Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
            [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MData -> [TypeVar] -> [TypeDescriptor] -> TypeDescriptor
TEmpty MData
mdata (Name -> TypeVar
Phantom 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HConstructor -> GenM ConstructorDescriptor
mkTdConstructor [HConstructor]
cs
                   forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ConstructorDescriptor
h forall a. a -> [a] -> NonEmpty a
:| [ConstructorDescriptor]
t
              let reifyInfo :: ReifyInfo
reifyInfo = [TypeVar] -> [Con] -> ReifyInfo
ReifyInfo ([Con] -> Name -> TypeVar
mkTypeArg [Con]
cnstrs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tVars) [Con]
cnstrs
              forall (f :: * -> *) a. Applicative f => a -> f a
pure 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MData -> TypeDescriptor
TPrimitive MData
md
toTypeDescriptor (HList HType
ht) = TypeDescriptor -> TypeDescriptor
TList 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HType -> GenM TypeDescriptor
toTypeDescriptor HType
ht
toTypeDescriptor (HRecursive MData
m) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MData -> TypeDescriptor
TRecusrive MData
m
toTypeDescriptor (HExternal ExInfo HType
e) = do
  [TypeDescriptor]
tds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HType -> GenM TypeDescriptor
toTypeDescriptor forall a b. (a -> b) -> a -> b
$ forall a. ExInfo a -> [a]
exTypeArgs ExInfo HType
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ExInfo TypeDescriptor -> TypeDescriptor
TExternal ExInfo HType
e {exTypeArgs :: [TypeDescriptor]
exTypeArgs = [TypeDescriptor]
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
        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
_) = 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
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
n, TypeDescriptor
td)
           in do [(Text, TypeDescriptor)]
a <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HField -> GenM (Text, TypeDescriptor)
mapFn [HField]
hfields
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> NonEmpty (Text, TypeDescriptor) -> ConstructorDescriptor
RecordConstructor Text
cname forall a b. (a -> b) -> a -> b
$ forall a. [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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HField -> GenM TypeDescriptor
mapFn [HField]
hfields
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> NonEmpty TypeDescriptor -> ConstructorDescriptor
SimpleConstructor Text
cname forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [TypeDescriptor]
a

mkTypeArg :: [Con] -> Name -> TypeVar
mkTypeArg :: [Con] -> Name -> TypeVar
mkTypeArg [Con]
constrs Name
name =
  if forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall a b. (a -> b) -> a -> b
$ Name -> Con -> Bool
searchCon Name
name 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 = forall (t :: * -> *). Foldable t => t Bool -> Bool
DL.or forall a b. (a -> b) -> a -> b
$ Name -> Type -> Bool
searchType Name
name 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_ 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) -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BangType]
args
    (RecC Name
_ [VarBangType]
args) -> (\(Name
_, Bang
_, Type
x) -> Type
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
args
    Con
_ -> 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 -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported type info" forall a. [a] -> [a] -> [a]
++ 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]
_) -> forall f. TyVarBndr f -> Name
mapFn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
args
    TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
args Maybe Type
_ Con
_ [DerivClause]
_) -> forall f. TyVarBndr f -> Name
mapFn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
args
    Info
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unimplemented"
  where
    mapFn :: TyVarBndr f -> Name
    mapFn :: forall f. TyVarBndr f -> Name
mapFn (PlainTV Name
n f
_) = Name
n
    mapFn (KindedTV Name
n f
_ 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 -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Unimplemented" forall a. [a] -> [a] -> [a]
++ 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 -> 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 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 <- 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
             forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- 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
             forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
             forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
             forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Maybe ", Text
a, Text
""]
           TTuple [TypeDescriptor]
tds -> do
             [Text]
ta <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\TypeDescriptor
x -> TypeDescriptor -> Bool -> Bool -> GenM Text
renderType TypeDescriptor
x Bool
False Bool
showPhantom) [TypeDescriptor]
tds
             forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"(", Text -> [Text] -> Text
T.intercalate Text
", " [Text]
ta, Text
")"]
           TPrimitive MData
md -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MData -> Text
_mTypeName MData
md
           TRecusrive MData
md -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MData -> Text
_mTypeName MData
md
           TExternal ExInfo TypeDescriptor
ei -> do
             [Text]
ta <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\TypeDescriptor
x -> TypeDescriptor -> Bool -> Bool -> GenM Text
renderType TypeDescriptor
x Bool
True Bool
showPhantom) forall a b. (a -> b) -> a -> b
$ forall a. ExInfo a -> [a]
exTypeArgs ExInfo TypeDescriptor
ei
             forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. ExInfo a -> ExItem
exType ExInfo TypeDescriptor
ei, Text
" ", Text -> [Text] -> Text
T.intercalate Text
" " [Text]
ta]
           TVar Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameToText Name
name
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (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 (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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
DL.null (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 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack 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) <- forall r (m :: * -> *). MonadReader r m => m r
ask
  case forall k a. Ord k => k -> Map k a -> Maybe a
DMS.lookup MData
tn GenConfig
x of
    Just ([GenOption], HType)
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([GenOption], HType) -> Bool
hasPoly' ([GenOption], HType)
b
    Maybe ([GenOption], HType)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  where
    hasPoly' :: ([GenOption], HType) -> Bool
    hasPoly' :: ([GenOption], HType) -> Bool
hasPoly' ([GenOption]
cl, HType
_) = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameToText Name
tv
renderTypeVar (Phantom Name
tv) = [Char] -> Text
pack 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 {} -> 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
_ -> 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 (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 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)) 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 forall a b. (a -> b) -> a -> b
$ Options -> ShowS
constructorTagModifier Options
opts forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack forall a b. (a -> b) -> a -> b
$ ConstructorDescriptor -> Text
getCName ConstructorDescriptor
cd
         , Bool -> ConstructorDescriptor -> Options -> ContentDecoder
mkContentDecoder Bool
False ConstructorDescriptor
cd Options
opts)) 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 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 forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ Options -> ShowS
fieldLabelModifier Options
opts 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]
_)) = 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]
_)) = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ExItem
ei]
collectExtRefs (TEmpty MData
_ [TypeVar]
_ [TypeDescriptor]
targs) = 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_) =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeDescriptor -> GenM ()
collectExtRefs 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
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
collectExtRefs (TRecusrive MData
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
collectExtRefs TypeDescriptor
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

getConstructorsFields :: Constructors -> [TypeDescriptor]
getConstructorsFields :: Constructors -> [TypeDescriptor]
getConstructorsFields Constructors
nec =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
DL.concat forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ 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) = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Text, TypeDescriptor)
nef
getConstructorFields_ (SimpleConstructor Text
_ NonEmpty TypeDescriptor
f) = 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]
_ -> forall a. a -> Maybe a
Just MData
md
    TOccupied MData
md ReifyInfo
_ [TypeDescriptor]
_ Constructors
_ -> forall a. a -> Maybe a
Just MData
md
    TPrimitive MData
md -> forall a. a -> Maybe a
Just MData
md
    TRecusrive MData
md -> forall a. a -> Maybe a
Just MData
md
    TypeDescriptor
_ -> forall a. Maybe a
Nothing