path: root/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs

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

module Language.Fiddle.Ast.Internal.SyntaxTree
  ( -- Type Families
    NumberType,
    ImportType,
    -- Witness Types
    Witness (..),
    WitnessType,
    -- AST Types
    Name (..),
    Directive (..),
    DirectiveBody (..),
    DirectiveElement (..),
    DirectiveExpression (..),
    Directed (..),
    FiddleUnit (..),
    Identifier (..),
    Expression (..),
    ImportStatement (..),
    ImportList (..),
    FiddleDecl (..),
    ObjTypeBody (..),
    ObjType (..),
    ObjTypeDecl (..),
    Modifier (..),
    ModifierKeyword (..),
    DeferredRegisterBody (..),
    BodyType (..),
    RegisterBody (..),
    RegisterBitsDecl (..),
    RegisterBitsTypeRef (..),
    AnonymousBitsType (..),
    BitType (..),
    EnumBody (..),
    EnumConstantDecl (..),
    PackageBody (..),
    -- Helper Functions
    mapDirected,
    mapDirectedM,
    asDirected,
    undirected,
    -- Utility Functions
    squeeze,
  )
where

import Data.Coerce
import Data.Functor.Identity
import Data.Kind (Type)
import Data.List.NonEmpty
import Data.Proxy
import Data.Text (Text)
import Data.Traversable
import Data.Type.Bool
import Data.Type.Equality
import Data.Typeable
import Data.Void (Void, absurd)
import GHC.Generics
import GHC.TypeLits
import Language.Fiddle.Ast.Internal.Generic
import Language.Fiddle.Ast.Internal.Instances
import Language.Fiddle.Ast.Internal.Kinds
import Language.Fiddle.Ast.Internal.Stage

-- The Type of number during each stage of compilation. When in the first stage,
-- numbers are just strings like anything else. In later stages, numbers get
-- parsed into actual integers. This makes it easier to process later.
type family NumberType (a :: Stage) :: Type where
  NumberType Stage1 = Text
  NumberType Stage2 = Integer
  NumberType s = NumberType (PreviousStage s)

-- The type that represents an import statement. In the early stages of
-- compilation, this is just a string representing the import path, but in later
-- stages of compilation, this actually gets replaced by an abstract
-- representation of the imported material.
type family ImportType (stage :: Stage) :: SynTree where
  ImportType Stage1 = ImportStatement
  ImportType Stage2 = ImportStatement
  ImportType Stage3 = ImportStatement

-- A way to disable or enable a subtree type based on a type-level boolean.
--
-- This is used over GADT's specific parameterization to allow for deriving
-- generics and reduce boilerplate.
--
-- This is a wrapper type to allow defining instances.
data Witness (s :: Bool) where
  Witness :: (WitnessType s) -> Witness s

-- | If the type level expression is true, the witness type is the Unit type, if
-- it is false, the witness type is Void, thus making whatever it touches
-- uninhabitable. This is how parts of the AST is enabled or disabled during
-- compilation.
type family WitnessType (s :: Bool) where
  WitnessType True = ()
  WitnessType False = Void

-- A Name is multiple identifiers separated by dots. It's the way of namespaces
-- to different packages.
data Name :: SynTree where
  Name :: NonEmpty (Identifier f a) -> a -> Name f a
  deriving (Generic, Annotated, Alter, Typeable)

-- Syntax tree fo the directive sublanguage. Directives can be on many elements
-- and provide the compiler with additional information about the emitted code.
--
-- The directive subtree by design does not depend on the compilation stage.
-- This is because the directive sublanguage should pass directly to the backend
-- compilation stage.
data Directive :: SynTree where
  Directive :: f (DirectiveBody f a) -> a -> Directive f a
  deriving (Generic, Annotated, Alter, Typeable)

-- A directive body has multiple directive elements.
data DirectiveBody :: SynTree where
  DirectiveBody :: [DirectiveElement f a] -> a -> DirectiveBody f a
  deriving (Generic, Annotated, Alter, Typeable)

-- Element in the directive.
data DirectiveElement :: SynTree where
  -- A directive can just be a key. Where the mere presence of the key has
  -- semantic value.
  DirectiveElementKey ::
    -- Which backend is this directive intended for?
    Maybe (Identifier f a) ->
    Identifier f a ->
    a ->
    DirectiveElement f a
  -- A directive can be more complex too. It can have an optional backend
  -- specificer, a key and a value.
  DirectiveElementKeyValue ::
    -- Which backend is this directive intendend for?
    Maybe (Identifier f a) ->
    -- The key for this directive.
    Identifier f a ->
    -- The value for this directive.
    DirectiveExpression f a ->
    a ->
    DirectiveElement f a
  deriving (Generic, Annotated, Alter, Typeable)

-- Expressions which can be found in the directive.
data DirectiveExpression f a where
  DirectiveString :: Text -> a -> DirectiveExpression f a
  DirectiveNumber :: Text -> a -> DirectiveExpression f a
  deriving (Generic, Annotated, Alter, Typeable)

-- A type, which wraps another syntax tree, but tacks on an array of directives.
-- that apply to the subtree.
data Directed t stage f a where
  Directed :: [Directive f a] -> t stage f a -> a -> Directed t stage f a
  deriving (Generic, Annotated, Alter, Typeable)

-- Apply a function to the underlying subtree in a Directed type.
mapDirected :: (t s f a -> t' s' f a) -> Directed t s f a -> Directed t' s' f a
mapDirected fn (Directed dr tfa a) = Directed dr (fn tfa) a

-- Apply a monadic function to the underlying subtree in a Directed type.
mapDirectedM ::
  (Monad m) => (t s f a -> m (t' s' f a)) -> Directed t s f a -> m (Directed t' s' f a)
mapDirectedM fn (Directed dr tfa a) = Directed dr <$> fn tfa <*> pure a

asDirected :: (Annotated (t s)) => t s f a -> Directed t s f a
asDirected tfa = Directed [] tfa (annot tfa)

undirected :: Directed t s f a -> t s f a
undirected (Directed _ tfa _) = tfa

-- Root of the parse tree. Just contains a list of declarations.
data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where
  FiddleUnit :: [Directed FiddleDecl stage f a] -> a -> FiddleUnit stage f a
  deriving (Generic, Annotated, Typeable)

deriving instance (Alter (ImportType stage)) => Alter (FiddleUnit stage)

-- Just an identifier.
data Identifier f a = Identifier !Text a
  deriving (Generic, Annotated, Alter, Typeable)

-- Expression.
data Expression (s :: Stage) :: SynTree where
  -- Just a string. Parsing the number comes in stage2.
  LitNum :: NumberType stage -> a -> Expression stage f a
  Var :: Identifier f a -> a -> Expression stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data ImportStatement f a where
  ImportStatement :: Text -> Maybe (ImportList f a) -> a -> ImportStatement f a
  deriving (Generic, Annotated, Alter, Typeable)

data ImportList f a where
  ImportList :: [Identifier f a] -> a -> ImportList f a
  deriving (Generic, Annotated, Alter, Typeable)

-- Top-level declarations.
data FiddleDecl :: StagedSynTree where
  {-
   - An option is a key/value pair.
   - option <ident> <ident>;
   -}
  OptionDecl ::
    Identifier f a ->
    Identifier f a ->
    a ->
    FiddleDecl stage f a
  ImportDecl ::
    ImportType stage f a ->
    a ->
    FiddleDecl stage f a
  UsingDecl ::
    Name f a -> a -> FiddleDecl stage f a
  {- Package Statement. Package Name, Package body -}
  PackageDecl ::
    Name f a ->
    f (PackageBody stage f a) ->
    a ->
    FiddleDecl stage f a
  {- location <identifier> = <expr>. -}
  LocationDecl ::
    Identifier f a ->
    Expression stage f a ->
    a ->
    FiddleDecl stage f a
  {- bits <identifier> : <type> -}
  BitsDecl ::
    Identifier f a ->
    BitType stage f a ->
    a ->
    FiddleDecl stage f a
  {- objtype <identifier> : <type> -}
  ObjTypeDecl ::
    Identifier f a ->
    f (ObjTypeBody stage f a) ->
    a ->
    FiddleDecl stage f a
  {- object <ident> at <expr> : <type> -}
  ObjectDecl ::
    Identifier f a ->
    Expression stage f a ->
    ObjType stage f a ->
    a ->
    FiddleDecl stage f a
  deriving (Generic, Annotated, Typeable)

deriving instance (Alter (ImportType stage)) => Alter (FiddleDecl stage)

data ObjTypeBody (stage :: Stage) (f :: Type -> Type) a where
  ObjTypeBody ::
    BodyType f a ->
    [Directed ObjTypeDecl stage f a] ->
    a ->
    ObjTypeBody stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data ObjType stage f a where
  -- { <body> }
  -- Anonymous types are only allowed in stage1. Stage2 should have them be
  -- de-anonymized.
  AnonymousObjType ::
    (Witness (stage == Stage1)) ->
    f (ObjTypeBody stage f a) ->
    a ->
    ObjType stage f a
  -- <type>[<expr>]
  ArrayObjType :: ObjType stage f a -> Expression stage f a -> a -> ObjType stage f a
  -- <identifier>
  ReferencedObjType :: Name f a -> a -> ObjType stage f a
  deriving (Typeable, Generic, Alter, Annotated, Typeable)

data ObjTypeDecl stage f a where
  {- assert_pos(<expr>) -}
  AssertPosStatement ::
    Witness (StageLessThan stage 3) ->
    Expression stage f a ->
    a ->
    ObjTypeDecl stage f a
  {- reg <ident>(<expr>) : <regtype> -}
  RegisterDecl ::
    Maybe (Modifier f a) ->
    Maybe (Identifier f a) ->
    Expression stage f a ->
    Maybe (RegisterBody stage f a) ->
    a ->
    ObjTypeDecl stage f a
  {- reserved(n); -}
  ReservedDecl :: Expression stage f a -> a -> ObjTypeDecl stage f a
  {- <struct|union> { subfields } <name>; -}
  TypeSubStructure ::
    f (ObjTypeBody stage f a) ->
    Maybe (Identifier f a) ->
    a ->
    ObjTypeDecl stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data Modifier f a where
  ModifierKeyword :: ModifierKeyword -> a -> Modifier f a
  deriving (Generic, Annotated, Alter, Typeable)

data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read, Typeable)

data DeferredRegisterBody stage f a where
  DeferredRegisterBody ::
    [Directed RegisterBitsDecl stage f a] ->
    a ->
    DeferredRegisterBody stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data BodyType (f :: Type -> Type) a where
  Union :: a -> BodyType f a
  Struct :: a -> BodyType f a
  deriving (Generic, Annotated, Alter, Typeable)

data RegisterBody stage f a where
  RegisterBody ::
    BodyType f a ->
    f (DeferredRegisterBody stage f a) ->
    a ->
    RegisterBody stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data RegisterBitsDecl stage f a where
  -- reserved(<expr>)
  ReservedBits :: Expression stage f a -> a -> RegisterBitsDecl stage f a
  -- <modifer> <ident> : <type>
  DefinedBits ::
    Maybe (Modifier f a) ->
    Identifier f a ->
    RegisterBitsTypeRef stage f a ->
    a ->
    RegisterBitsDecl stage f a
  BitsSubStructure ::
    RegisterBody stage f a ->
    Maybe (Identifier f a) ->
    a ->
    RegisterBitsDecl stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data RegisterBitsTypeRef stage f a where
  -- <type>[<expr>]
  RegisterBitsArray ::
    RegisterBitsTypeRef stage f a ->
    Expression stage f a ->
    a ->
    RegisterBitsTypeRef stage f a
  {- Reference to a type. -}
  RegisterBitsReference :: Name f a -> a -> RegisterBitsTypeRef stage f a
  {- enum(<expr>) { <body> }
     Anonymous types are only allowed in stage1.
     Stage2 should de-anonymize these type. -}
  RegisterBitsAnonymousType ::
    Witness (stage == Stage1) ->
    AnonymousBitsType stage f a ->
    a ->
    RegisterBitsTypeRef stage f a
  {- (<expr>)
   -
   - The expression is just bits ... i.e. an integer.
   -}
  RegisterBitsJustBits ::
    Expression stage f a ->
    a ->
    RegisterBitsTypeRef stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data AnonymousBitsType stage f a where
  -- enum(<expr>) { <body> }
  AnonymousEnumBody ::
    Expression stage f a ->
    f (EnumBody stage f a) ->
    a ->
    AnonymousBitsType stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data BitType (stage :: Stage) (f :: Type -> Type) a where
  -- enum(<expr>) { <body> }
  EnumBitType ::
    Expression stage f a ->
    f (EnumBody stage f a) ->
    a ->
    BitType stage f a
  -- (<expr>)
  RawBits :: Expression stage f a -> a -> BitType stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data EnumBody (stage :: Stage) (f :: Type -> Type) a where
  -- <decl>,
  EnumBody :: [Directed EnumConstantDecl stage f a] -> a -> EnumBody stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data EnumConstantDecl stage f a where
  -- <ident> = <expr>
  EnumConstantDecl ::
    Identifier f a ->
    Expression stage f a ->
    a ->
    EnumConstantDecl stage f a
  -- reserved = <expr>
  EnumConstantReserved ::
    Expression stage f a ->
    a ->
    EnumConstantDecl stage f a
  deriving (Generic, Annotated, Alter, Typeable)

data PackageBody (stage :: Stage) (f :: Type -> Type) a where
  {- The body of a package -}
  PackageBody :: [Directed FiddleDecl stage f a] -> a -> PackageBody stage f a
  deriving (Generic, Annotated, Typeable)

deriving instance (Alter (ImportType stage)) => Alter (PackageBody stage)

squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a)
squeeze = alter (fmap Identity) return

-- Expression involves NumberType, so we add the constraint:
deriving instance (Functor f, NumberType s ~ NumberType s') => EasySwitchStage Expression f s s'

-- FiddleDecl includes both NumberType and ImportType, so we need both constraints:
deriving instance
  ( Functor f,
    StageLessThan s 3 ~ StageLessThan s' 3,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s',
    ImportType s ~ ImportType s'
  ) =>
  EasySwitchStage FiddleDecl f s s'

-- ObjType includes NumberType, so we add the constraint:
deriving instance
  ( Functor f,
    StageLessThan s 3 ~ StageLessThan s' 3,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s'
  ) =>
  EasySwitchStage ObjType f s s'

-- ObjTypeBody doesn't have any special type families, so no additional constraints:
deriving instance
  ( Functor f,
    StageLessThan s 3 ~ StageLessThan s' 3,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s'
  ) =>
  EasySwitchStage ObjTypeBody f s s'

-- ObjTypeDecl doesn't have special type families, so no additional constraints:
deriving instance
  ( Functor f,
    StageLessThan s 3 ~ StageLessThan s' 3,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s'
  ) =>
  EasySwitchStage ObjTypeDecl f s s'

-- DeferredRegisterBody doesn't have special type families:
deriving instance
  ( Functor f,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s'
  ) =>
  EasySwitchStage DeferredRegisterBody f s s'

-- RegisterBody depends on NumberType, so we add that constraint:
deriving instance
  ( Functor f,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s'
  ) =>
  EasySwitchStage RegisterBody f s s'

-- RegisterBitsDecl depends on NumberType:
deriving instance
  ( Functor f,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s'
  ) =>
  EasySwitchStage RegisterBitsDecl f s s'

-- RegisterBitsTypeRef depends on NumberType:
deriving instance
  ( Functor f,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s'
  ) =>
  EasySwitchStage RegisterBitsTypeRef f s s'

-- AnonymousBitsType depends on NumberType:
deriving instance
  (Functor f, NumberType s ~ NumberType s') =>
  EasySwitchStage AnonymousBitsType f s s'

-- BitType depends on NumberType:
deriving instance
  (Functor f, NumberType s ~ NumberType s') =>
  EasySwitchStage BitType f s s'

-- EnumBody doesn't depend on any type families:
deriving instance
  (Functor f, NumberType s ~ NumberType s') =>
  EasySwitchStage EnumBody f s s'

-- EnumConstantDecl depends on NumberType:
deriving instance
  (Functor f, NumberType s ~ NumberType s') =>
  EasySwitchStage EnumConstantDecl f s s'

-- PackageBody includes both NumberType and ImportType:
deriving instance
  ( Functor f,
    StageLessThan s 3 ~ StageLessThan s' 3,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s',
    ImportType s ~ ImportType s'
  ) =>
  EasySwitchStage PackageBody f s s'

-- FiddleUnit includes NumberType and ImportType, so we need both constraints:
deriving instance
  ( Functor f,
    StageLessThan s 3 ~ StageLessThan s' 3,
    (s == Stage1) ~ (s' == Stage1),
    NumberType s ~ NumberType s',
    ImportType s ~ ImportType s'
  ) =>
  EasySwitchStage FiddleUnit f s s'

-- Directed depends on its underlying AST type:
deriving instance
  (EasySwitchStage t f s s') =>
  EasySwitchStage (Directed t) f s s'