{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE QuasiQuotes         #-}
module Data.Aeson.Generics.TypeScript
  ( -- * Primary generation functions
    getPrintedDefinition
  , printTS
    -- * Type Classes
  , FieldTypeName (..)
  , TypeScriptDefinition (..)
    -- * TypeScript AST data types
  , FieldSpec (..)
  , FieldType (..)
  , IsNewtype (..)
  , TSField (..)
  , TSGenericVar
  , TSInterface (..)
  , TSType (..)
    -- * Convenience builders
  , concretely
  , genericly
  ) where

import           Data.Char (toUpper)
import           Data.Containers.ListUtils (nubOrd)
import           Data.Data (Proxy (..))
import           Data.Kind (Constraint, Type)
import           Data.List (intercalate)
import           Data.List.NonEmpty (NonEmpty, toList)
import           Data.Map (Map)
import           Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import           Data.String.Interpolate (i)
import qualified Data.Text as T
import           Data.Time.Clock (UTCTime)
import           GHC.Generics
  ( C1
  , D1
  , Generic (Rep)
  , Meta (MetaCons, MetaData, MetaSel)
  , Rec0
  , S1
  , U1
  , type (:*:)
  , type (:+:)
  )
import           GHC.TypeLits
  ( ErrorMessage (ShowType, Text, (:$$:), (:<>:))
  , KnownSymbol
  , Symbol
  , TypeError
  , symbolVal
  )

-- | Type level rep of a named generic type variable
type TSGenericVar :: Symbol -> Type
data TSGenericVar s

-- | Determine if this is a newtype and will not be wrapped
type IsNewtype :: Type
data IsNewtype
  = Newtype
  | Oldtype
  deriving stock (Eq, Ord, Show)

-- | The top level TypeScript type declaration
type TSType :: Type
data TSType = TSType
  { tst_constructor :: !String
  , tst_doc         :: !String
  , tst_interfaces  :: !(NonEmpty TSInterface)
  , tst_newtype     :: !IsNewtype
  }
  deriving stock (Eq, Ord, Show)

-- | A term constructor in Haskell, most likely an interface in TypeScript
type TSInterface :: Type
data TSInterface = TSInterface
  { tsi_constructor :: !String
  , tsi_typeName    :: !(Maybe String)
  , tsi_members     :: ![TSField]
  }
  deriving stock (Eq, Ord, Show)

-- | Fields can be concrete types, or generic type variables
type FieldType :: Type
data FieldType
  = GenericField
  | ConcreteField
  deriving stock (Bounded, Enum, Eq, Ord, Show)
instance Semigroup FieldType where
  GenericField <> _ = GenericField
  _ <> GenericField = GenericField
  _ <> _            = ConcreteField

-- | A field within a term constructor
type TSField :: Type
data TSField = TSField
  { fieldName :: !(Maybe String)
  , fieldType :: !FieldSpec
  }
  deriving stock (Eq, Ord, Show)

-- | Helper for printing fields
type FieldSpec :: Type
data FieldSpec = FieldSpec
  { fs_type      :: !FieldType
  , fs_wrapped   :: !String
  , fs_unwrapped :: !String
  }
  deriving stock (Eq, Ord, Show)

-- | Construct a FieldSpec assuming standard use and a concrete type variable
concretely :: String -> FieldSpec
concretely x = FieldSpec ConcreteField x x

-- | Construct a FieldSpec assuming standard use and a generic type variable
genericly :: String -> FieldSpec
genericly x = FieldSpec GenericField x x

-- | Typeclass to determine the FieldSpec from a payload's type
type FieldTypeName :: a -> Constraint
class FieldTypeName a where
  fieldTypeName :: Proxy a -> FieldSpec

-- | Lists are Arrays according to Aeson
instance FieldTypeName a => FieldTypeName [a] where
  fieldTypeName _ = let
      FieldSpec t wrapped unwrapped = fieldTypeName $ Proxy @a
    in FieldSpec t ("Array<" <> wrapped <> ">") unwrapped

-- | Handle wrapped payload
instance FieldTypeName a => FieldTypeName (Rec0 a) where
  fieldTypeName _ = fieldTypeName $ Proxy @a

-- | This needs to overlap so it doesn't get treated as an Array
instance {-# OVERLAPS #-} FieldTypeName String where
  fieldTypeName _ = concretely "string"

instance FieldTypeName UTCTime where
  fieldTypeName _ = concretely "string"

instance FieldTypeName T.Text where
  fieldTypeName _ = concretely "string"

instance (FieldTypeName a, FieldTypeName b) =>  FieldTypeName (Either a b) where
  fieldTypeName _ =
    let a = fieldTypeName (Proxy @a)
        b = fieldTypeName (Proxy @b)
        eType l r = [i|{ Left: #{l} } | { Right: #{r} }|]
    in FieldSpec (fs_type a <> fs_type b) (fs_wrapped a `eType` fs_wrapped b) (fs_unwrapped a `eType` fs_unwrapped b)

instance (FieldTypeName a, FieldTypeName b) => FieldTypeName (Map a b) where
  fieldTypeName _ = FieldSpec (fs_type a <> fs_type b) asMap $ fs_unwrapped a <> "," <> fs_unwrapped b
    where
      a = fieldTypeName $ Proxy @a
      b = fieldTypeName $ Proxy @b
      wrappedB = fs_wrapped b
      asMap = [i|{ [key: string]: #{wrappedB} }|]

instance FieldTypeName Int where fieldTypeName _ = concretely "number"
instance FieldTypeName Integer where fieldTypeName _ = concretely "number"
instance FieldTypeName Float where fieldTypeName _ = concretely "number"
instance FieldTypeName Bool where fieldTypeName _ = concretely "boolean"
instance FieldTypeName a => FieldTypeName (Maybe a) where
  fieldTypeName _ = inner { fs_wrapped = fs_wrapped inner <> " | null" }
    where inner = fieldTypeName (Proxy @a)

instance FieldTypeName () where
  fieldTypeName _ = concretely "[]"

instance {-# OVERLAPPABLE #-} TypeScriptDefinition a => FieldTypeName a where
  fieldTypeName _ = let x = gen @a in ly x $ tst_constructor x where
    ly TSType {..} = if any ((== GenericField) . fs_type . fieldType) . mconcat . toList $ tsi_members <$> tst_interfaces
                     then genericly else concretely

instance KnownSymbol s => FieldTypeName (TSGenericVar s) where
  fieldTypeName _ = genericly . cap . symbolVal $ Proxy @s
    where cap (x:xs) = toUpper x : xs
          cap []     = []

-- | This typeclass provides the ability to derive a TSType from any Generic data type
type TypeScriptDefinition :: Type -> Constraint
class TypeScriptDefinition a where
  gen :: TSType
  default gen ::
    ( TSType ~ GTypeScriptTail (Rep a)
    , GTypeScriptDef (Rep a)) => TSType
  gen = ggen $ Proxy @(Rep a)

-- | Custom error for missing TypeScriptDefinition's, as they can be a red herring
instance TypeError
  ('Text "No instance of TypeScriptDefinition found for: " ':<>: 'ShowType a ':$$:
   'Text "💠 If you are seeing this for a newtype of something primitive, derive FieldTypeName instead.") => TypeScriptDefinition a where
  gen = error "unreachable"

-- | Generic deriving mechanism for TypeScriptDefinition
type GTypeScriptDef :: a -> Constraint
class GTypeScriptDef a where
  type GTypeScriptTail a :: Type
  ggen :: Proxy a -> GTypeScriptTail a

-- | This is the top level of the Generic structure, D1, which holds top level 'Metadata
instance
  ( KnownSymbol name
  , KnownSymbol module'
  , KnownSymbol package
  , GTypeScriptDef u
  , GTypeScriptTail u ~ NonEmpty TSInterface
  , isNew `DegradesTo` Bool
  ) => GTypeScriptDef (D1 ('MetaData name module' package isNew) u) where
  type GTypeScriptTail (D1 ('MetaData name module' package isNew) u) = TSType
  ggen _ = TSType
    (symbolVal (Proxy @name))
    ("Defined in " <> symbolVal (Proxy @module') <> " of " <> symbolVal (Proxy @package))
    (ggen (Proxy @u))
    (if degrade (Proxy @isNew) then Newtype else Oldtype)

-- | Handler for Generic constructors, which we convert to @TSInterfaces@
instance
  ( KnownSymbol name
  , GTypeScriptDef u
  , GTypeScriptTail u ~ [TSField]
  ) => GTypeScriptDef (C1 ('MetaCons name fixity hasNames) u) where
  type GTypeScriptTail (C1 ('MetaCons name fixity hasNames) u) = NonEmpty TSInterface
  ggen _ = pure $ TSInterface (symbolVal (Proxy @name)) Nothing (checkTSFields $ ggen $ Proxy @u)
    where
    -- Sanity checker @TSField@, this is useful to ensure invariants assumed by JavaScript objects
    checkTSFields ts = let
        uniqueFieldNames = nubOrd $ fieldName <$> ts
      in if length uniqueFieldNames /= length ts
         && not (all (isNothing . fieldName) ts)
      then error $ "record field names are not unique : " <> show ts
      else ts

instance GTypeScriptDef U1 where
  type GTypeScriptTail U1 = [TSField]
  ggen _ = []

instance
  ( FieldTypeName u, w `DegradesTo` Maybe String
  )=> GTypeScriptDef (S1 ('MetaSel w x y z) u) where
  type GTypeScriptTail (S1 ('MetaSel w x y z) u) = [TSField]
  ggen _ = pure $ TSField
    { fieldName = degrade $ Proxy @w
    , fieldType = fieldTypeName $ Proxy @u
    }

instance
  ( GTypeScriptTail x ~ NonEmpty TSInterface
  , GTypeScriptTail y ~ NonEmpty TSInterface
  , GTypeScriptDef x, GTypeScriptDef y
  ) => GTypeScriptDef (x :+: y) where
  type GTypeScriptTail (x :+: y) = NonEmpty TSInterface
  ggen _ = ggen (Proxy @x) <> ggen (Proxy @y)

instance
  ( GTypeScriptTail a ~ [TSField]
  , GTypeScriptTail b ~ [TSField]
  , GTypeScriptDef a, GTypeScriptDef b
  ) => GTypeScriptDef (a :*: b) where
  type GTypeScriptTail (a :*: b) = [TSField]
  ggen _ = ggen (Proxy @a) <> ggen (Proxy @b)

printTS :: TSType -> String
printTS TSType{..} =
    [i|// #{tst_doc}
#{typeDecl}|] <> if isEnum || isPureProduct then "" else
      (if isSingleRecord then id else mappend "\n") interfaces
    where
      -- All the type variables found
      vars :: [TSField]
      vars = mconcat . toList $ tsi_members <$> tst_interfaces

      -- The generic variables in TypeScript syntax IE <A,B>
      -- These must be unique
      generics :: String
      generics = mkGenericVars $ nubOrd vars

      -- The constructors of the original haskell data type as our AST
      constructors :: [(String, [TSField])]
      constructors = toList $ (\x -> (tsi_constructor x,tsi_members x)) <$> tst_interfaces

      -- The interfaces associated with the constructors in TypeScript syntax
      interfaces :: String
      interfaces = if null tst_interfaces then "" else
        intercalate "\n" . toList $ printTSInterface . hackInTypeName <$> tst_interfaces

      -- Is this going to be a special variant for Aeson?
      isUnit, isSingleRecord, isPureProduct, isEnum :: Bool
      isUnit = length constructors == 1 && isEnum
      isSingleRecord = length constructors == 1 && all (all (isJust . fieldName) . tsi_members) tst_interfaces
      isPureProduct = length constructors == 1
        && all (all (isNothing . fieldName) . tsi_members) tst_interfaces
      isEnum = all (\TSInterface{..} -> null tsi_members) tst_interfaces

      -- When we are in a single record context, the interface gets named as the
      -- name of the type, not after the term constructor like normal. So we hack it in with an override
      hackInTypeName :: TSInterface -> TSInterface
      hackInTypeName face = if isSingleRecord then face { tsi_typeName = Just tst_constructor } else face

      -- The declaration of the type, if not a single record (which is just the inner interface)
      typeDecl :: String
      typeDecl = if isSingleRecord && not isUnit then "" :: String else
        [i|type #{tst_constructor}#{generics} = #{transObj};|] where
          transObj
            -- Aeson says so
            | isUnit = "[]"
            -- Its a newtype
            | tst_newtype == Newtype = case vars of
                              [TSField {..}] -> fs_wrapped fieldType
                              _ -> error $ "newtype wrong number of fields: " <> show vars
            -- This is a data type with mulitple fields and only one constructor, and so is a big tuple
            | isPureProduct = "[" <> intercalate ", " ((\TSField {..} -> fs_wrapped fieldType) <$> vars) <> "]"
            -- Its a union type
            | otherwise = intercalate " | "
                  . fmap (if isEnum then (\x ->  "\"" <> x <> "\"") else id)
                  $ (\(c,ms) -> c <> mkGenericVars ms) <$> constructors

printTSInterface :: TSInterface -> String
printTSInterface TSInterface{..} = [i|interface #{typeName}#{generics} {
  #{tag}readonly tag: "#{tsi_constructor}";|]
    <> (if null contents then "" else "\n" <> contents)
    <> "\n}" where
     -- The name of the type for use in the top of the interface declaration
     -- This is different if we are in a single record context. When we are a single
     -- record, the interface needs to be the type name, not the term constructor name
     typeName :: String
     typeName = fromMaybe tsi_constructor tsi_typeName

     -- If we are in the single record context, we leave the constructor name
     -- around as a code comment for debugging
     tag :: String
     tag = if isJust tsi_typeName then "// " else ""

     -- Make list of variables for contents
     unnamed :: String
     unnamed = flip mappend ";" $
       if length ms > 1 then "[" <> intercalate ", " ms <> "]" else mconcat ms
       where ms = fs_wrapped . fieldType <$> tsi_members

     -- Payload of the interface
     contents :: String
     contents = if isRecord then intercalate "\n" $ namedField <$> tsi_members
                            else "  readonly contents: " <> unnamed

     -- Do all fields have names?
     isRecord :: Bool
     isRecord = all (isJust . fieldName) tsi_members

     -- Build one named field
     namedField :: TSField -> String
     namedField TSField {..} = "  readonly " <> fieldName' <> ": " <> fieldType' <> ";"
       where fieldName' = fromMaybe (error "field name was not found") fieldName
             fieldType' = fs_wrapped fieldType

     -- Generics of the system
     generics :: String
     generics = mkGenericVars tsi_members

mkGenericVars :: [TSField] -> String
mkGenericVars xs = if null vars then "" else "<" <> intercalate "," vars <> ">"
  where
  vars = mapMaybe (go . fieldType) xs
  go = \case x@(FieldSpec GenericField _ _) -> Just $ fs_unwrapped x; _ -> Nothing

-- | degrade :: 'Maybe Symbol -> Maybe String
type Degrade :: k -> Constraint
class Degrade (w :: k) where
  type Degraded w :: Type
  degrade :: Proxy w -> Degraded w
instance KnownSymbol s => Degrade ('Just s) where
  type Degraded ('Just s) = Maybe String
  degrade _ = Just $ symbolVal $ Proxy @s
instance Degrade 'Nothing where
  type Degraded 'Nothing = Maybe String
  degrade _ = Nothing
instance Degrade 'True where
  type Degraded  'True = Bool
  degrade _ =     True
instance Degrade 'False where
  type Degraded  'False = Bool
  degrade _ =     False
instance Degrade 'Newtype where
  type Degraded  'Newtype = IsNewtype
  degrade _ =     Newtype
instance Degrade 'Oldtype where
  type Degraded  'Oldtype = IsNewtype
  degrade _ =     Oldtype

type DegradesTo :: k -> Type -> Constraint
type DegradesTo x t = (Degraded x ~ t, Degrade x)

-- | Get the TypeScriptDefinition as a String
getPrintedDefinition :: forall a. TypeScriptDefinition a => Proxy a -> String
getPrintedDefinition _ = printTS $ gen @a

-- This is present as debugging tool
type Foo :: Type -> Type
data Foo a = Foo
           | Bar Int
  deriving stock (Eq, Generic, Ord, Read, Show)
  deriving anyclass (TypeScriptDefinition)