{-# 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 Data.Foldable (Foldable (toList))
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,
    ToGenericSyntaxTreeValue (NumberType stage),
    Show (ImportInterface stage),
    Show (FiddleUnitInterface stage),
    Show (QualificationMetadata stage ())
  )

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

alterGenericSyntaxTree ::
  (Functor f) =>
  (GenericSyntaxTree f a -> Maybe (GenericSyntaxTree f a)) ->
  GenericSyntaxTree f a ->
  GenericSyntaxTree f a
alterGenericSyntaxTree fn genericTree
  | (Just newGenericTree) <- fn genericTree = newGenericTree
  | otherwise =
      case genericTree of
        SyntaxTreeObject str members annot tree ->
          SyntaxTreeObject
            str
            (map (alterGenericSyntaxTree fn) members)
            annot
            tree
        SyntaxTreeList members ->
          SyntaxTreeList $ map (alterGenericSyntaxTree fn) members
        SyntaxTreeDeferred sub ->
          SyntaxTreeDeferred $ fmap (alterGenericSyntaxTree fn) sub
        v -> v

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 (GenericSyntaxTree f (Maybe Value)) where
  toJSON = \case
    (SyntaxTreeObject typ membs Nothing _) ->
      object ["_con" .= typ, "_members" .= membs]
    (SyntaxTreeObject typ membs (Just 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 (Just a) t) ->
      pairs $ "_type" .= show (typeOf t) <> "_con" .= typ <> "_members" .= membs <> "_annot" .= a
    (SyntaxTreeObject typ membs Nothing t) ->
      pairs $ "_type" .= show (typeOf t) <> "_con" .= typ <> "_members" .= membs
    (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 -> Maybe (GenericSyntaxTree f a)
  default toGenericSyntaxTreeValue ::
    forall f a. (Show v) => v -> Maybe (GenericSyntaxTree f a)
  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show

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

instance (Show s) => ToGenericSyntaxTreeValue s where
  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show

-- Witnesses exist just for type level meta programming, don't return anything
-- if we don't need it.
instance ToGenericSyntaxTreeValue (Witness b) where
  toGenericSyntaxTreeValue _ = Nothing

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

class ToGenericSyntaxTree (t :: SynTree) 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, Typeable f, Typeable a) => t f a -> 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 _ = toList . 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 (ToGenericSyntaxTree Name)

deriving instance (ToGenericSyntaxTree BodyType)

deriving instance (ToGenericSyntaxTree Directive)

deriving instance (ToGenericSyntaxTree DirectiveBody)

deriving instance (ToGenericSyntaxTree DirectiveElement)

deriving instance (ToGenericSyntaxTree DirectiveExpression)

deriving instance (ToGenericSyntaxTree ImportList)

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

deriving instance
  (Context stage, ToGenericSyntaxTree (t stage), Typeable t) =>
  (ToGenericSyntaxTree (Directed t stage))

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

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

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

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

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

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))

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

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))

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