path: root/src/Language/Fiddle/GenericTree.hs

{-# 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.Identity (Identity)
import Data.Aeson.Encoding (text)
import Data.Aeson.Types as Aeson
import Data.Foldable (Foldable (toList))
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.Internal.UnitInterface
import Language.Fiddle.Types

type Context stage =
  ( Show (NumberType stage),
    Typeable stage,
    ToJSON (NumberType stage),
    ToJSON (RegisterOffset stage),
    ToJSON (ImportInterface stage),
    ToJSON (FiddleUnitInterface stage),
    ToJSON (QualificationMetadata stage ()),
    ToJSON (QualificationMetadata stage ExportedPackageDecl),
    ToJSON (QualificationMetadata stage ExportedLocationDecl),
    ToJSON (QualificationMetadata stage ExportedBitsDecl),
    ToJSON (QualificationMetadata stage ExportedTypeDecl),
    ToJSON (QualificationMetadata stage ExportedObjectDecl)
  )

class FunctorShow f where
  showf :: (Show a) => f a -> String

instance (Show l) => FunctorShow (Either l) where
  showf = show

instance FunctorShow Maybe where
  showf = show

instance FunctorShow Identity where
  showf = show

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 :: Value -> 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 a tree ->
          SyntaxTreeObject
            str
            (map (alterGenericSyntaxTree fn) members)
            a
            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 (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) -> toJSON 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 v) -> toEncoding v

class ToGenericSyntaxTreeValue f v where
  toGenericSyntaxTreeValue :: forall a. v -> Maybe (GenericSyntaxTree f a)
  default toGenericSyntaxTreeValue ::
    forall a. (ToJSON v) => v -> Maybe (GenericSyntaxTree f a)
  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . toJSON

instance ToGenericSyntaxTreeValue f Data.Text.Text where
  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . String

instance (ToJSON s) => ToGenericSyntaxTreeValue f s where
  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . toJSON

-- Witnesses exist just for type level meta programming, don't return anything
-- if we don't need it.
instance ToGenericSyntaxTreeValue f (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 f 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
--   GToGenericSyntaxTree (Rec0 (f x)) f a
--   where
--   gToGenericSyntaxTree _ k1 = SyntaxTreeList []

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

instance (ToGenericSyntaxTreeValue f ModifierKeyword) where
  toGenericSyntaxTreeValue kw = Just $ SyntaxTreeValue $ String (Data.Text.pack $ show kw)

instance (Functor f, ToJSON a) => (ToGenericSyntaxTreeValue f (f a)) where
  toGenericSyntaxTreeValue mv =
     Just $ SyntaxTreeDeferred $ SyntaxTreeValue . toJSON <$> mv

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