{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Language.Fiddle.GenericTree where

import Control.Monad.Writer (execWriter, tell)
import Data.Aeson (Value (..), foldable, object, toEncoding, toJSON)
import Data.Aeson.Encoding (text)
import Data.Aeson.Types as Aeson
import qualified Data.Foldable
import Data.Functor.Classes (Show1, liftShowsPrec)
import Data.Kind (Type)
import Data.Proxy
import qualified Data.Text
import Data.Typeable
import qualified Data.Vector
import GHC.Generics
import GHC.TypeLits (KnownSymbol, symbolVal)
import Language.Fiddle.Ast
import Language.Fiddle.Types
import Text.Parsec.Pos
import Text.Printf (printf)

type Context stage = (Show (NumberType stage), Typeable stage)

data GenericSyntaxTree f a where
  {- GenericSyntaxtTree with a name and children. -}
  SyntaxTreeObject ::
    forall a f tree.
    (Typeable tree) =>
    String ->
    [GenericSyntaxTree f a] ->
    a ->
    tree ->
    GenericSyntaxTree f a
  SyntaxTreeList :: [GenericSyntaxTree f a] -> GenericSyntaxTree f a
  SyntaxTreeDeferred :: f (GenericSyntaxTree f a) -> GenericSyntaxTree f a
  SyntaxTreeValue :: String -> GenericSyntaxTree f a

instance ToJSON Comment where
  toJSON (NormalComment str) = object ["normal" .= str]
  toJSON (DocComment str) = object ["doc" .= str]

instance (ToJSON a) => ToJSON (Commented a) where
  toJSON (Commented comment a) =
    object ["comment" .= comment, "annot" .= a]

instance ToJSON SourceSpan where
  toJSON (SourceSpan start end) =
    object ["start" .= toJSON start, "end" .= toJSON end]

instance ToJSON SourcePos where
  toJSON sourcePos =
    object
      [ "name" .= sourceName sourcePos,
        "row" .= sourceLine sourcePos,
        "col" .= sourceColumn sourcePos
      ]

instance (Foldable f, ToJSON a) => ToJSON (GenericSyntaxTree f a) where
  toJSON = \case
    (SyntaxTreeObject typ membs a _) ->
      object ["_con" .= typ, "_members" .= membs, "_annot" .= a]
    (SyntaxTreeList l) ->
      Array $ Data.Vector.fromList $ map toJSON l
    (SyntaxTreeDeferred fdef) ->
      toJSON (SyntaxTreeList $ Data.Foldable.toList fdef)
    (SyntaxTreeValue s) -> String (Data.Text.pack s)

  toEncoding = \case
    (SyntaxTreeObject typ membs a t) ->
      pairs $ "_type" .= show (typeOf t) <> "_con" .= typ <> "_members" .= membs <> "_annot" .= a
    (SyntaxTreeList l) ->
      foldable $ map toJSON l
    (SyntaxTreeDeferred fdef) ->
      toEncoding (SyntaxTreeList $ Data.Foldable.toList fdef)
    (SyntaxTreeValue s) -> text (Data.Text.pack s)

class ToGenericSyntaxTreeValue v where
  toGenericSyntaxTreeValue :: forall f a. v -> GenericSyntaxTree f a
  default toGenericSyntaxTreeValue ::
    forall f a. (Show v) => v -> GenericSyntaxTree f a
  toGenericSyntaxTreeValue = SyntaxTreeValue . show

instance ToGenericSyntaxTreeValue Data.Text.Text where
  toGenericSyntaxTreeValue = SyntaxTreeValue . Data.Text.unpack

type GenericContext t f a = (Traversable f, ToGenericSyntaxTree t, Typeable t, Typeable f, Typeable a)

class ToGenericSyntaxTree (t :: (Type -> Type) -> Type -> Type) where
  toGenericSyntaxTree :: (Traversable f, Typeable f, Typeable t, Typeable a) => t f a -> GenericSyntaxTree f a
  default toGenericSyntaxTree ::
    (GenericContext t f a, Generic (t f a), (GToGenericSyntaxTree (Rep (t f a)) f a)) =>
    t f a ->
    GenericSyntaxTree f a
  toGenericSyntaxTree t = gToGenericSyntaxTree t (from t)

class GToGenericSyntaxTree r f a where
  gToGenericSyntaxTree :: (Typeable t) => t -> r x -> GenericSyntaxTree f a

class GToMemberList r f a where
  gToMemberList :: Int -> r x -> [GenericSyntaxTree f a]

instance (ToGenericSyntaxTreeValue v) => GToMemberList (Rec0 v) f a where
  gToMemberList _ = (: []) . toGenericSyntaxTreeValue . unK1

instance
  (GenericContext r f a) =>
  GToGenericSyntaxTree (Rec0 (f (r f a))) f a
  where
  gToGenericSyntaxTree _ k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1)

instance
  (GenericContext r f a, Traversable f1) =>
  GToGenericSyntaxTree (Rec0 (f1 (r f a))) f a
  where
  gToGenericSyntaxTree _ k1 =
    SyntaxTreeList (Data.Foldable.toList $ toGenericSyntaxTree <$> unK1 k1)

instance
  (GToMemberList r f a, GToMemberList l f a) =>
  GToMemberList (l :*: r) f a
  where
  gToMemberList n (l :*: r) = l1 ++ gToMemberList (length l1) r
    where
      l1 = gToMemberList n l

instance (GenericContext t f a) => GToMemberList (Rec0 (t f a)) f a where
  gToMemberList _ a = [toGenericSyntaxTree (unK1 a)]

instance
  (GenericContext t f a, Foldable l) =>
  GToMemberList (Rec0 (l (t f a))) f a
  where
  gToMemberList _ as = toGenericSyntaxTree <$> Data.Foldable.toList (unK1 as)

instance GToMemberList (Rec0 a) f a where
  gToMemberList _ _ = []

instance (GToMemberList r f a) => GToMemberList (M1 i c r) f a where
  gToMemberList n (M1 r) = gToMemberList n r

instance (GenericContext r f a) => GToGenericSyntaxTree (Rec0 (r f a)) f a where
  gToGenericSyntaxTree _ k1 = toGenericSyntaxTree $ unK1 k1

instance
  (GToMemberList r f a, KnownSymbol name, GAnnot a r) =>
  (GToGenericSyntaxTree (C1 ('MetaCons name _f _b) r)) f a
  where
  gToGenericSyntaxTree t c =
    SyntaxTreeObject (symbolVal (nameProxy c)) (gToMemberList 0 (unM1 c)) (gannot c) t
    where
      nameProxy :: C1 ('MetaCons name _f _b) r x -> Proxy name
      nameProxy _ = Proxy

instance
  (GToGenericSyntaxTree l f a, GToGenericSyntaxTree r f a) =>
  (GToGenericSyntaxTree (l :+: r) f a)
  where
  gToGenericSyntaxTree t (L1 l) = gToGenericSyntaxTree t l
  gToGenericSyntaxTree t (R1 r) = gToGenericSyntaxTree t r

instance (GToGenericSyntaxTree r f a) => (GToGenericSyntaxTree (M1 i c r) f a) where
  gToGenericSyntaxTree t (M1 r) = gToGenericSyntaxTree t r

-- deriving instance (ToGenericSyntaxTree (Test stage))

deriving instance (ToGenericSyntaxTree Identifier)

deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleUnit stage))

deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleDecl stage))

instance (Context stage) => ToGenericSyntaxTree (ObjType stage) where
  toGenericSyntaxTree t = case t of
    (AnonymousObjType body annot) ->
      SyntaxTreeDeferred $
        fmap
          ( \body' ->
              SyntaxTreeObject
                "AnonymousObjType"
                [toGenericSyntaxTree body']
                annot
                body'
          )
          body
    (ArrayObjType arr expr annot) ->
      SyntaxTreeObject
        "ArrayObjType"
        [toGenericSyntaxTree arr, toGenericSyntaxTree expr]
        annot
        t
    (ReferencedObjType ident a) ->
      SyntaxTreeObject "ReferencedObjType" [toGenericSyntaxTree ident] a t

deriving instance (Context stage) => (ToGenericSyntaxTree (ObjTypeBody stage))

instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage)) where
  toGenericSyntaxTree t = case t of
    (AssertPosStatement expr a) ->
      SyntaxTreeObject "AssertPosStatement" [toGenericSyntaxTree expr] a t
    (RegisterDecl mMod mIdent expr mBody a) ->
      SyntaxTreeObject
        "RegisterDecl"
        ( Data.Foldable.toList (toGenericSyntaxTree <$> mMod)
            ++ Data.Foldable.toList (toGenericSyntaxTree <$> mIdent)
            ++ [toGenericSyntaxTree expr]
            ++ Data.Foldable.toList (toGenericSyntaxTree <$> mBody)
        )
        a
        t

deriving instance (ToGenericSyntaxTreeValue ModifierKeyword)

deriving instance (ToGenericSyntaxTree Modifier)

deriving instance (Context stage) => (ToGenericSyntaxTree (DeferredRegisterBody stage))

deriving instance (Context stage) => (ToGenericSyntaxTree (RegisterBody stage))

deriving instance (Context stage) => (ToGenericSyntaxTree (RegisterBitsDecl stage))

instance (Context stage) => ToGenericSyntaxTree (RegisterBitsTypeRef stage) where
  toGenericSyntaxTree t = case t of
    (RegisterBitsArray ref exp a) ->
      SyntaxTreeObject
        "RegisterBitsArray"
        [toGenericSyntaxTree ref, toGenericSyntaxTree exp]
        a
        t
    (RegisterBitsReference i a) ->
      SyntaxTreeObject "RegisterBitsReference" [toGenericSyntaxTree i] a t
    (RegisterBitsAnonymousType t a) ->
      SyntaxTreeObject "RegisterBitsAnonymousType " [toGenericSyntaxTree t] a t
    (RegisterBitsJustBits t a) ->
      SyntaxTreeObject "RegisterBitsJustBits " [toGenericSyntaxTree t] a t

deriving instance (Context stage) => (ToGenericSyntaxTree (AnonymousBitsType stage))

deriving instance (Context stage) => (ToGenericSyntaxTree (BitType stage))

deriving instance (Context stage) => (ToGenericSyntaxTree (EnumBody stage))

deriving instance (Context stage) => (ToGenericSyntaxTree (EnumConstantDecl stage))

deriving instance (Context stage) => (ToGenericSyntaxTree (PackageBody stage))

instance (Context stage) => (ToGenericSyntaxTree (Expression stage)) where
  toGenericSyntaxTree tr = case tr of
    LitNum t a -> SyntaxTreeObject "LitNum" [SyntaxTreeValue (show t)] a tr
    Var t a -> SyntaxTreeObject "LitNum" [toGenericSyntaxTree t] a tr