{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}

module Elmental (
    ElmDeclarable (..),
    HasElmStructure,
    ElmMapping (..),
    HasSymbolInfo,
    ElmKind,
    defaultMapping,
    getElmStructure,
    getTypeName,
    getModuleName,
    getMapping,
    setModule,
    module Elmental.ElmStructure,
) where

import Data.Kind (Type)
import Data.Proxy
import Data.Text (Text)
import Data.Text qualified as Text
import Elmental.ElmStructure
import GHC.Generics qualified as GHC
import GHC.TypeLits
import Generics.Kind

type family KindOf (x :: k) :: Type where
    KindOf (_ :: k) = k

{- | Class mapping a Haskell type constructor @x :: k@ to an Elm type constructor.

  You can define instances for this class for any Haskell data / newtype constructor,
  be it unapplied, partially applied or fully applied, provided that its kind is
  not Elm-compatible (i.e., not higher-kinded).

  For example:

  @
    data SomeHKT f a = SomeHKT (f a)

    instance ElmDeclarable ((Type -> Type) -> Type) SomeHKT -- Not OK: SomeHKT is higher-kinded.
    instance ElmDeclarable (Type -> Type) (SomeHKT Maybe) -- OK
    instance ElmDeclarable Type (SomeHKT Maybe Int) -- OK

    instance ElmDeclarable [] -- OK
    instance ElmDeclarable [Char] -- OK
 @
-}
class (ElmKind (KindOf x)) => ElmDeclarable x where
    -- | Elm mapping information.
    --
    --  Contains the name / location of the type and its encoder / decoder.
    --  Can be overridden.
    --
    --  Example:
    --
    --  @
    --    instance ElmDeclarable Type [Char] where
    --      mapTo = ElmMapping
    --        { typeName = "String"
    --        , moduleName = Nothing
    --        , encoderLocation = Just $ SymbolLocation
    --            { symbolName = "string"
    --            , moduleName = "Json.Encode"
    --            }
    --        , decoderLocation = Just $ SymbolLocation
    --            { symbolName = "string"
    --            , moduleName = "Json.Decode"
    --            }
    --        , args = []
    --        }
    --  @
    mapTo :: ElmMapping
    default mapTo :: (HasSymbolInfo x) => ElmMapping
    mapTo = forall (x :: k). HasSymbolInfo x => ElmMapping
forall {k} (x :: k). HasSymbolInfo x => ElmMapping
defaultMapping @x

    -- | Internal function. You should not have to define this method yourself.
    mkTyRef :: PList (NParams (KindOf x)) TyRef -> TyRef
    default mkTyRef :: PList (NParams (KindOf x)) TyRef -> TyRef
    mkTyRef PList (NParams (KindOf x)) TyRef
pList = TyCon -> [TyRef] -> TyRef
TyRef (ElmMapping -> TyCon
TyMapping (forall (x :: k). ElmDeclarable x => ElmMapping
forall {k} (x :: k). ElmDeclarable x => ElmMapping
mapTo @x)) (PList (NParams k) TyRef -> [TyRef]
forall (n :: PNat) a. PList n a -> [a]
pListToList PList (NParams k) TyRef
PList (NParams (KindOf x)) TyRef
pList)

{- | Instance for applied type constructors.

  Necessary to traverse the list of type constructors down to the root when constructing
  type references to applied type constructors.
-}
instance
    {-# OVERLAPPABLE #-}
    forall k (t :: Type) (x :: Type -> k).
    ( ElmDeclarable t
    , ElmDeclarable (x :: Type -> k)
    ) =>
    ElmDeclarable (x t)
    where
    mapTo :: ElmMapping
mapTo =
        let tMapping :: ElmMapping
tMapping = forall x. ElmDeclarable x => ElmMapping
forall {k} (x :: k). ElmDeclarable x => ElmMapping
mapTo @t
            xMapping :: ElmMapping
xMapping = forall {k} (x :: k). ElmDeclarable x => ElmMapping
forall (x :: * -> k). ElmDeclarable x => ElmMapping
mapTo @x
         in ElmMapping
xMapping{args = xMapping.args <> [tMapping]}

    mkTyRef :: PList (NParams (KindOf (x t))) TyRef -> TyRef
mkTyRef PList (NParams (KindOf (x t))) TyRef
remainingParams = forall {k} (x :: k).
ElmDeclarable x =>
PList (NParams (KindOf x)) TyRef -> TyRef
forall (x :: * -> k).
ElmDeclarable x =>
PList (NParams (KindOf x)) TyRef -> TyRef
mkTyRef @x ((forall x.
ElmDeclarable x =>
PList (NParams (KindOf x)) TyRef -> TyRef
forall {k} (x :: k).
ElmDeclarable x =>
PList (NParams (KindOf x)) TyRef -> TyRef
mkTyRef @t PList (NParams (KindOf t)) TyRef
PList 'Z TyRef
forall a. PList 'Z a
PNil) TyRef -> PList (NParams k) TyRef -> PList ('S (NParams k)) TyRef
forall a (n :: PNat). a -> PList n a -> PList ('S n) a
`PCons` PList (NParams k) TyRef
PList (NParams (KindOf (x t))) TyRef
remainingParams)

type HasSymbolInfo x =
    ( KnownSymbol (GetTypeNameG (RepK x))
    , KnownSymbol (GetModuleNameG (RepK x))
    )

defaultMapping :: forall x. (HasSymbolInfo x) => ElmMapping
defaultMapping :: forall {k} (x :: k). HasSymbolInfo x => ElmMapping
defaultMapping =
    ElmMapping
        { $sel:typeName:ElmMapping :: SymbolName
typeName = SymbolName
tName
        , $sel:moduleName:ElmMapping :: Maybe SymbolName
moduleName = SymbolName -> Maybe SymbolName
forall a. a -> Maybe a
Just SymbolName
mName
        , $sel:encoderLocation:ElmMapping :: Maybe SymbolLocation
encoderLocation =
            SymbolLocation -> Maybe SymbolLocation
forall a. a -> Maybe a
Just (SymbolLocation -> Maybe SymbolLocation)
-> SymbolLocation -> Maybe SymbolLocation
forall a b. (a -> b) -> a -> b
$
                SymbolLocation
                    { $sel:symbolName:SymbolLocation :: SymbolName
symbolName = SymbolName
"encode" SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
tName
                    , $sel:symbolModuleName:SymbolLocation :: SymbolName
symbolModuleName = SymbolName
mName
                    }
        , $sel:decoderLocation:ElmMapping :: Maybe SymbolLocation
decoderLocation =
            SymbolLocation -> Maybe SymbolLocation
forall a. a -> Maybe a
Just (SymbolLocation -> Maybe SymbolLocation)
-> SymbolLocation -> Maybe SymbolLocation
forall a b. (a -> b) -> a -> b
$
                SymbolLocation
                    { $sel:symbolName:SymbolLocation :: SymbolName
symbolName = SymbolName
"decode" SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> SymbolName
tName
                    , $sel:symbolModuleName:SymbolLocation :: SymbolName
symbolModuleName = SymbolName
mName
                    }
        , $sel:args:ElmMapping :: [ElmMapping]
args = []
        , $sel:isTypeAlias:ElmMapping :: Bool
isTypeAlias = Bool
False
        , $sel:urlPiece:ElmMapping :: Maybe SymbolLocation
urlPiece = Maybe SymbolLocation
forall a. Maybe a
Nothing
        , $sel:queryParam:ElmMapping :: Maybe SymbolLocation
queryParam = Maybe SymbolLocation
forall a. Maybe a
Nothing
        }
  where
    tName :: SymbolName
tName = forall (sym :: Symbol). KnownSymbol sym => SymbolName
symbolToText @(GetTypeNameG (RepK x))
    mName :: SymbolName
mName = forall (sym :: Symbol). KnownSymbol sym => SymbolName
symbolToText @(GetModuleNameG (RepK x))

{- | Overrides / sets the module name everywhere in a mapping.
 Often useful in conjunction wit @defaultMapping@.
-}
setModule :: Text -> ElmMapping -> ElmMapping
setModule :: SymbolName -> ElmMapping -> ElmMapping
setModule SymbolName
moduleName ElmMapping
mapping =
    ElmMapping
mapping
        { moduleName = Just moduleName
        , decoderLocation =
            ( \SymbolLocation
l ->
                SymbolLocation
l
                    { symbolModuleName = moduleName
                    }
            )
                <$> mapping.decoderLocation
        , encoderLocation =
            ( \SymbolLocation
l ->
                SymbolLocation
l
                    { symbolModuleName = moduleName
                    }
            )
                <$> mapping.encoderLocation
        }

-- Type metadata utilities
type family GetModuleNameG x where
    GetModuleNameG (M1 _d ('GHC.MetaData _tyConName moduleName _pkg _isNewtype) _sop) = moduleName

type family GetTypeNameG x where
    GetTypeNameG (M1 _d ('GHC.MetaData tyConName _moduleName _pkg _isNewtype) _sop) = tyConName

symbolToText :: forall sym. (KnownSymbol sym) => Text
symbolToText :: forall (sym :: Symbol). KnownSymbol sym => SymbolName
symbolToText = String -> SymbolName
Text.pack (String -> SymbolName) -> String -> SymbolName
forall a b. (a -> b) -> a -> b
$ Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @sym)

getMapping :: forall x. (ElmDeclarable x) => ElmMapping
getMapping :: forall {k} (x :: k). ElmDeclarable x => ElmMapping
getMapping = forall (x :: k). ElmDeclarable x => ElmMapping
forall {k} (x :: k). ElmDeclarable x => ElmMapping
mapTo @x

getTypeName :: forall x. (ElmDeclarable x) => Text
getTypeName :: forall {k} (x :: k). ElmDeclarable x => SymbolName
getTypeName = (forall (x :: k). ElmDeclarable x => ElmMapping
forall {k} (x :: k). ElmDeclarable x => ElmMapping
getMapping @x).typeName

getModuleName :: forall x. (ElmDeclarable x) => Maybe Text
getModuleName :: forall {k} (x :: k). ElmDeclarable x => Maybe SymbolName
getModuleName = (forall (x :: k). ElmDeclarable x => ElmMapping
forall {k} (x :: k). ElmDeclarable x => ElmMapping
getMapping @x).moduleName

-- Usual Peano numbers / length-indexed lists stuff.
data PNat = Z | S PNat

type family PNatToNat (n :: PNat) :: Natural where
    PNatToNat Z = 0
    PNatToNat (S n) = 1 + PNatToNat n

data PList (n :: PNat) a where
    PNil :: PList Z a
    PCons :: a -> PList n a -> PList (S n) a

pListToList :: PList n a -> [a]
pListToList :: forall (n :: PNat) a. PList n a -> [a]
pListToList PList n a
PNil = []
pListToList (a
a `PCons` PList n a
as) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (PList n a -> [a]
forall (n :: PNat) a. PList n a -> [a]
pListToList PList n a
as)

-- | Constraint establishing that a kind is valid in Elm.
type ElmKind k = ElmKindB k ~ True

type family ElmKindB k :: Bool where
    ElmKindB Type = True
    ElmKindB (Type -> k) = ElmKindB k

-- Compute the number of type parameters of a type constuctor.
type family NParams k :: PNat where
    NParams Type = Z
    NParams (Type -> k) = S (NParams k)

-- This shouldn't have to be a class as it only has a single instance,
-- but it seems to be the only way to expose @HasElmStructure@ as a simple
-- constraint.
class (repK ~ RepK x) => HasElmStructure' k (x :: k) repK where
    getElmStructure' :: DatatypeStructure x

instance
    ( ElmDeclarable x
    , RepK x ~ M1 GHC.D ('GHC.MetaData tName mName pkg isNewtype) sop
    , GElmSum sop
    , KnownNat (PNatToNat (NParams (KindOf x)))
    ) =>
    HasElmStructure' k x (M1 GHC.D ('GHC.MetaData tName mName pkg isNewtype) sop)
    where
    getElmStructure' :: DatatypeStructure x
getElmStructure' =
        DatatypeStructure
            { $sel:mapping:DatatypeStructure :: ElmMapping
mapping = forall (x :: k). ElmDeclarable x => ElmMapping
forall {k} (x :: k). ElmDeclarable x => ElmMapping
getMapping @x
            , $sel:nParams:DatatypeStructure :: Integer
nParams = Proxy (PNatToNat (NParams k)) -> Integer
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy (PNatToNat (NParams k)) -> Integer)
-> Proxy (PNatToNat (NParams k)) -> Integer
forall a b. (a -> b) -> a -> b
$ forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(PNatToNat (NParams k))
            , $sel:constructors:DatatypeStructure :: [Constructor]
constructors = forall k (sop :: k). GElmSum sop => [Constructor]
getValueConstructors @_ @sop
            }

type HasElmStructure k x = HasElmStructure' k x (RepK x)

{- | Extract the structure of the representation of a datatype in Elm.

Used by code generation.
-}
getElmStructure :: forall {k} (x :: k). (HasElmStructure k x) => DatatypeStructure x
getElmStructure :: forall {k} (x :: k). HasElmStructure k x => DatatypeStructure x
getElmStructure = forall k (x :: k) (repK :: LoT k -> *).
HasElmStructure' k x repK =>
DatatypeStructure x
getElmStructure' @k @x @(RepK x)

-- Extraction logic.
--
-- We essentially pattern-match on the Generic representation to extract:
--
-- - Elm metadata attached via the @ElmDeclarable@ class (type name and module name).
-- - Constructors (GElmSum).
-- - Fields, their names, and their types (potentially involving type variables).

class GElmSum (sop :: k) where
    getValueConstructors :: [Constructor]

instance
    ( KnownSymbol valConName
    , GElmProduct fields
    ) =>
    GElmSum (M1 GHC.C ('GHC.MetaCons valConName 'GHC.PrefixI isNt) fields)
    where
    getValueConstructors :: [Constructor]
getValueConstructors =
        [ Constructor
            { $sel:constructorName:Constructor :: SymbolName
constructorName = forall (sym :: Symbol). KnownSymbol sym => SymbolName
symbolToText @valConName
            , $sel:constructorFields:Constructor :: [ElmField]
constructorFields = forall k (fields :: k). GElmProduct fields => [ElmField]
getFields @_ @fields
            }
        ]

instance
    ( KnownSymbol valConName
    , GElmProduct fields
    , GElmSum otherCons
    ) =>
    GElmSum (M1 GHC.C ('GHC.MetaCons valConName 'GHC.PrefixI isNt) fields :+: otherCons)
    where
    getValueConstructors :: [Constructor]
getValueConstructors =
        ( Constructor
            { $sel:constructorName:Constructor :: SymbolName
constructorName = String -> SymbolName
Text.pack (String -> SymbolName) -> String -> SymbolName
forall a b. (a -> b) -> a -> b
$ Proxy valConName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @valConName)
            , $sel:constructorFields:Constructor :: [ElmField]
constructorFields = forall k (fields :: k). GElmProduct fields => [ElmField]
getFields @_ @fields
            }
        )
            Constructor -> [Constructor] -> [Constructor]
forall a. a -> [a] -> [a]
: forall k (sop :: k). GElmSum sop => [Constructor]
getValueConstructors @_ @otherCons

instance
    ( GElmSum (s1 :+: s2)
    , GElmSum otherCons
    ) =>
    GElmSum ((s1 :+: s2) :+: otherCons)
    where
    getValueConstructors :: [Constructor]
getValueConstructors =
        forall k (sop :: k). GElmSum sop => [Constructor]
getValueConstructors @_ @(s1 :+: s2)
            [Constructor] -> [Constructor] -> [Constructor]
forall a. [a] -> [a] -> [a]
++ forall k (sop :: k). GElmSum sop => [Constructor]
getValueConstructors @_ @otherCons

class GElmProduct (fields :: k) where
    getFields :: [ElmField]

instance GElmProduct U1 where
    getFields :: [ElmField]
getFields = []

instance
    (GElmField (M1 GHC.S ('GHC.MetaSel mbFName u s l) fieldType)) =>
    GElmProduct (M1 GHC.S ('GHC.MetaSel mbFName u s l) fieldType)
    where
    getFields :: [ElmField]
getFields = [forall {k} (field :: k). GElmField field => ElmField
forall (field :: k -> *). GElmField field => ElmField
getField @(M1 GHC.S ('GHC.MetaSel mbFName u s l) fieldType)]

instance (GElmProduct (f1 :*: f2), GElmProduct fields) => GElmProduct ((f1 :*: f2) :*: fields) where
    getFields :: [ElmField]
getFields = (forall k (fields :: k). GElmProduct fields => [ElmField]
getFields @_ @(f1 :*: f2)) [ElmField] -> [ElmField] -> [ElmField]
forall a. [a] -> [a] -> [a]
++ (forall k (fields :: k). GElmProduct fields => [ElmField]
getFields @_ @fields)

instance (GElmField (M1 s m t), GElmProduct fields) => GElmProduct ((M1 s m t) :*: fields) where
    getFields :: [ElmField]
getFields = (forall {k} (field :: k). GElmField field => ElmField
forall (field :: k -> *). GElmField field => ElmField
getField @(M1 s m t)) ElmField -> [ElmField] -> [ElmField]
forall a. a -> [a] -> [a]
: (forall k (fields :: k). GElmProduct fields => [ElmField]
getFields @_ @fields)

class GElmField field where
    getField :: ElmField

instance
    (GElmFieldType Z fieldType, KnownSymbol fieldName) =>
    GElmField (M1 GHC.S ('GHC.MetaSel (Just fieldName) u s l) (Field fieldType))
    where
    getField :: ElmField
getField = (SymbolName -> Maybe SymbolName
forall a. a -> Maybe a
Just (forall (sym :: Symbol). KnownSymbol sym => SymbolName
symbolToText @fieldName), forall {k} (nParams :: PNat) (fieldType :: k).
GElmFieldType nParams fieldType =>
PList nParams TyRef -> TyRef
forall (nParams :: PNat) (fieldType :: Atom d (*)).
GElmFieldType nParams fieldType =>
PList nParams TyRef -> TyRef
getTyRef @Z @fieldType PList 'Z TyRef
forall a. PList 'Z a
PNil)

instance
    (GElmFieldType Z fieldType) =>
    GElmField (M1 GHC.S ('GHC.MetaSel Nothing u s l) (Field fieldType))
    where
    getField :: ElmField
getField = (Maybe SymbolName
forall a. Maybe a
Nothing, forall {k} (nParams :: PNat) (fieldType :: k).
GElmFieldType nParams fieldType =>
PList nParams TyRef -> TyRef
forall (nParams :: PNat) (fieldType :: Atom d (*)).
GElmFieldType nParams fieldType =>
PList nParams TyRef -> TyRef
getTyRef @Z @fieldType PList 'Z TyRef
forall a. PList 'Z a
PNil)

class GElmFieldType (nParams :: PNat) fieldType where
    getTyRef :: PList nParams TyRef -> TyRef

class HasNat (vn :: k) where
    type ToNat vn :: Nat

-- GHC refuses a simple type family declaration (probably because the kinds vary).
instance HasNat VZ where
    type ToNat VZ = 0
instance HasNat (VS vn) where
    type ToNat (VS vn) = 1 + (ToNat vn)

instance (KnownNat (ToNat vn)) => GElmFieldType Z ('Var vn) where
    getTyRef :: PList 'Z TyRef -> TyRef
getTyRef PList 'Z TyRef
_ = TyCon -> [TyRef] -> TyRef
TyRef (SymbolName -> TyCon
TyVar (SymbolName -> TyCon) -> SymbolName -> TyCon
forall a b. (a -> b) -> a -> b
$ SymbolName
"a" SymbolName -> SymbolName -> SymbolName
forall a. Semigroup a => a -> a -> a
<> String -> SymbolName
Text.pack (Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ Proxy (ToNat vn) -> Integer
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy (ToNat vn) -> Integer) -> Proxy (ToNat vn) -> Integer
forall a b. (a -> b) -> a -> b
$ forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ToNat vn))) []

instance (ElmDeclarable someType, nParams ~ NParams (KindOf someType)) => GElmFieldType nParams ('Kon someType) where
    getTyRef :: PList nParams TyRef -> TyRef
getTyRef PList nParams TyRef
params = forall (x :: k1).
ElmDeclarable x =>
PList (NParams (KindOf x)) TyRef -> TyRef
forall {k} (x :: k).
ElmDeclarable x =>
PList (NParams (KindOf x)) TyRef -> TyRef
mkTyRef @someType PList nParams TyRef
PList (NParams (KindOf someType)) TyRef
params

instance
    (GElmFieldType Z t2, GElmFieldType (S n) t1) =>
    GElmFieldType n (t1 :@: t2)
    where
    getTyRef :: PList n TyRef -> TyRef
getTyRef PList n TyRef
params = forall {k} (nParams :: PNat) (fieldType :: k).
GElmFieldType nParams fieldType =>
PList nParams TyRef -> TyRef
forall (nParams :: PNat) (fieldType :: Atom d (k1 -> k2)).
GElmFieldType nParams fieldType =>
PList nParams TyRef -> TyRef
getTyRef @(S n) @t1 ((forall {k} (nParams :: PNat) (fieldType :: k).
GElmFieldType nParams fieldType =>
PList nParams TyRef -> TyRef
forall (nParams :: PNat) (fieldType :: Atom d k1).
GElmFieldType nParams fieldType =>
PList nParams TyRef -> TyRef
getTyRef @Z @t2 PList 'Z TyRef
forall a. PList 'Z a
PNil) TyRef -> PList n TyRef -> PList ('S n) TyRef
forall a (n :: PNat). a -> PList n a -> PList ('S n) a
`append` PList n TyRef
params)

append :: a -> PList n a -> PList (S n) a
append :: forall a (n :: PNat). a -> PList n a -> PList ('S n) a
append a
a PList n a
PNil = a
a a -> PList n a -> PList ('S n) a
forall a (n :: PNat). a -> PList n a -> PList ('S n) a
`PCons` PList n a
PList 'Z a
forall a. PList 'Z a
PNil
append a
a (a
b `PCons` PList n a
bs) = (a
b a -> PList n a -> PList ('S n) a
forall a (n :: PNat). a -> PList n a -> PList ('S n) a
`PCons` (a
a a -> PList n a -> PList ('S n) a
forall a (n :: PNat). a -> PList n a -> PList ('S n) a
`append` PList n a
bs))