{-# 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.Proxy
import qualified Data.Text
import qualified Data.Vector
import GHC.Generics
import GHC.TypeLits (KnownSymbol, symbolVal)
import Language.Fiddle.Ast
import Text.Printf (printf)

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

instance (Foldable f, Show a) => ToJSON (GenericSyntaxTree f a) where
  toJSON = \case
    (SyntaxTreeObject typ membs a) ->
      object ["_type" .= typ, "_members" .= membs, "_annot" .= show 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) ->
      pairs $ "_type" .= typ <> "_members" .= membs <> "_annot" .= show 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

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

class GToGenericSyntaxTree r f a where
  gToGenericSyntaxTree :: 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
  (Traversable f, ToGenericSyntaxTree r) =>
  GToGenericSyntaxTree (Rec0 (f (r f a))) f a
  where
  gToGenericSyntaxTree k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1)

instance
  (Traversable f, Traversable f1, ToGenericSyntaxTree r) =>
  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 (ToGenericSyntaxTree t, Traversable f) => GToMemberList (Rec0 (t f a)) f a where
  gToMemberList _ a = [toGenericSyntaxTree (unK1 a)]

instance
  (ToGenericSyntaxTree t, Traversable f, 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 (ToGenericSyntaxTree r, Traversable f) => 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 c =
    SyntaxTreeObject (symbolVal (nameProxy c)) (gToMemberList 0 (unM1 c)) (gannot c)
    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 (L1 l) = gToGenericSyntaxTree l
  gToGenericSyntaxTree (R1 r) = gToGenericSyntaxTree r

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

-- deriving instance (ToGenericSyntaxTree (Test stage))

deriving instance (ToGenericSyntaxTree (Identifier stage))

deriving instance (ToGenericSyntaxTree (FiddleUnit stage))

deriving instance (ToGenericSyntaxTree (FiddleDecl stage))

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

deriving instance (ToGenericSyntaxTree (ObjTypeBody stage))

deriving instance (ToGenericSyntaxTree (ObjTypeDecl stage))

deriving instance (ToGenericSyntaxTreeValue ModifierKeyword)

deriving instance (ToGenericSyntaxTree (Modifier stage))

deriving instance (ToGenericSyntaxTree (DeferredRegisterBody stage))

deriving instance (ToGenericSyntaxTree (RegisterBody stage))

deriving instance (ToGenericSyntaxTree (RegisterBitsDecl stage))

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

deriving instance (ToGenericSyntaxTree (AnonymousBitsType stage))

deriving instance (ToGenericSyntaxTree (BitType stage))

deriving instance (ToGenericSyntaxTree (EnumBody stage))

deriving instance (ToGenericSyntaxTree (EnumConstantDecl stage))

deriving instance (ToGenericSyntaxTree (PackageBody stage))

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