summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Language/Fiddle/Ast/Internal/Instances.hs11
-rw-r--r--src/Language/Fiddle/Ast/Internal/SyntaxTree.hs47
-rw-r--r--src/Language/Fiddle/Compiler/Backend/C.hs2
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs16
-rw-r--r--src/Language/Fiddle/Compiler/Expansion.hs8
-rw-r--r--src/Language/Fiddle/Compiler/Qualification.hs17
-rw-r--r--src/Language/Fiddle/GenericTree.hs9
-rw-r--r--src/Language/Fiddle/Parser.hs17
8 files changed, 61 insertions, 66 deletions
diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs
index 8222174..1ab943f 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances.hs
@@ -2,6 +2,7 @@ module Language.Fiddle.Ast.Internal.Instances
( module X,
Alter (..),
AdvanceStage (..),
+ StageConvertible (..),
CompilationStage (..),
Annotated (..),
GAnnot (..),
@@ -94,6 +95,16 @@ class
instance (CompilationStage s, Applicative (StageMonad s)) => StageConvertible s a a where
convertInStage _ _ _ = pure
+instance
+ ( CompilationStage s,
+ Applicative (StageMonad s),
+ Traversable f,
+ StageConvertible s a b
+ ) =>
+ StageConvertible s (f a) (f b)
+ where
+ convertInStage pxy ann st = mapM (convertInStage pxy ann st)
+
-- | 'AdvanceStage' defines how to transform an Abstract Syntax Tree (AST) node
-- from one stage to the next in the compiler pipeline. This transformation
-- can be customized per node type, or a default generic implementation can be
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 66b8e42..6f67149 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -3,17 +3,16 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Fiddle.Ast.Internal.SyntaxTree
( -- Type Families
NumberType,
- FiddleUnitInterface,
- QualificationMetadata,
- CommonQualificationData (..),
RegisterOffset,
BitsOffset,
+ QMd (..),
-- Witness Types
Witness (..),
-- AST Types
@@ -53,29 +52,22 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
where
import Control.Monad (forM_)
+import Data.Aeson (ToJSON (..))
import Data.Kind (Type)
import Data.List.NonEmpty hiding (map)
import Data.Text (Text)
import Data.Type.Bool
+import Data.Type.Equality
import Data.Typeable
import Data.Word (Word32)
import GHC.Generics
import Language.Fiddle.Ast.Internal.Instances
import Language.Fiddle.Ast.Internal.Kinds
-import Language.Fiddle.Ast.Internal.Stage
import Language.Fiddle.Ast.Internal.MetaTypes
+import Language.Fiddle.Ast.Internal.Stage
import Language.Fiddle.Internal.UnitInterface
-import Data.Type.Equality
-import GHC.TypeError as TypeError
-import GHC.TypeLits
-
--- | Common data for each qualified element.
-newtype CommonQualificationData
- = CommonQualificationData
- { -- The fully qualified path to this qualified element.
- fullyQualifiedPath :: [String]
- }
- deriving (Eq, Ord, Show)
+
+type QMd s t = When (s .>= Qualified) t
type BitsOffset stage = RegisterOffset stage
@@ -85,17 +77,6 @@ type BitsOffset stage = RegisterOffset stage
type family RegisterOffset stage where
RegisterOffset stage = If (stage .< Checked) () Word32
--- | Type which stores metadata after qualification. Before qualification, this
--- metadata has not been calculated and so is unset.
-type family QualificationMetadata stage t where
- QualificationMetadata stage t =
- If (stage .< Qualified) () t
-
--- | The type attached to import statements which describe the imported file's
--- unit interface
-type family FiddleUnitInterface (s :: Stage) :: Type where
- FiddleUnitInterface s = If (s .< Checked) () UnitInterface
-
-- | 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.
@@ -341,7 +322,7 @@ data FiddleDecl :: StagedSynTree where
PackageDecl ::
{ -- | Qualification metadata about this package statement.
packageQualificationMetadata ::
- f (QualificationMetadata stage ExportedPackageDecl),
+ f (QMd stage ExportedPackageDecl),
-- | The package name.
packageName :: Name f a,
-- | The body of the package.
@@ -354,7 +335,7 @@ data FiddleDecl :: StagedSynTree where
LocationDecl ::
{ -- | qualified metadata about this location.
locationQualificationMetadata ::
- f (QualificationMetadata stage ExportedLocationDecl),
+ f (QMd stage ExportedLocationDecl),
-- | The location identifier.
locationIdent :: Identifier f a,
-- | The associated expression.
@@ -366,7 +347,7 @@ data FiddleDecl :: StagedSynTree where
-- | A bits declaration in the form 'bits <identifier> : <type>'.
BitsDecl ::
{ -- | Qualification metadata about this "bits" declaration.
- bitsQualificationMetadata :: f (QualificationMetadata stage ExportedBitsDecl),
+ bitsQualificationMetadata :: f (QMd stage ExportedBitsDecl),
-- | The identifier of the bits.
bitsIdent :: Identifier f a,
-- | The type of the bits.
@@ -378,7 +359,7 @@ data FiddleDecl :: StagedSynTree where
-- | An object type declaration.
ObjTypeDecl ::
{ -- | Qualification metadata about this object type.
- objTypeQualificationMetadata :: f (QualificationMetadata stage ExportedTypeDecl),
+ objTypeQualificationMetadata :: f (QMd stage ExportedTypeDecl),
-- | The identifier of the object type.
objTypeIdent :: Identifier f a,
-- | The body of the object type.
@@ -390,7 +371,7 @@ data FiddleDecl :: StagedSynTree where
-- | An object declaration in the form 'object <ident> at <expr> : <type>'.
ObjectDecl ::
{ -- | Qualification metadata about this object.
- objectQualificationMetadata :: f (QualificationMetadata stage ExportedObjectDecl),
+ objectQualificationMetadata :: f (QMd stage ExportedObjectDecl),
-- | The identifier of the object.
objectIdent :: Identifier f a,
-- | The location expression.
@@ -442,7 +423,7 @@ data ObjType stage f a where
ObjType stage f a
-- | A reference to an existing type by name.
ReferencedObjType ::
- { refQualificationMetadata :: f (QualificationMetadata stage ExportedTypeDecl),
+ { refQualificationMetadata :: f (QMd stage ExportedTypeDecl),
-- | The name of the referenced type.
refName :: Name f a,
-- | Annotation for the referenced type.
@@ -609,7 +590,7 @@ data RegisterBitsTypeRef stage f a where
-- | A reference to another type by name.
RegisterBitsReference ::
{ -- | Qualification metadata about this Bits reference.
- bitsRefQualificationMetadata :: f (QualificationMetadata stage ExportedBitsDecl),
+ bitsRefQualificationMetadata :: f (QMd stage ExportedBitsDecl),
-- | The name of the referenced type.
bitsRefName :: Name f a,
-- | Annotation for the reference.
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index 5379099..2e6421e 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -265,7 +265,7 @@ transpileWalk sourceFile headerFile t _ = case () of
withFileAt headerFile middlePos $ do
pad $ do
emitDocComments a
- struct (identifierFor metadata) $ do
+ struct (identifierFor (unwrap metadata)) $ do
structBody objTypeBody
return Stop
_ -> return (Continue ())
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index a4f252e..552ea40 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -35,6 +35,9 @@ type A = Commented SourceSpan
type M = Compile ()
+pattern QMdP :: t -> Identity (When True t)
+pattern QMdP t = Identity (Present t)
+
instance CompilationStage Checked where
type StageAfter Checked = TypeError (TypeError.Text "No stage after Checked")
type StageMonad Checked = M
@@ -85,19 +88,19 @@ instance AdvanceStage S FiddleUnit where
doWalk t =
case () of
()
- | (Just (PackageDecl {packageQualificationMetadata = (Identity d)})) <-
+ | (Just (PackageDecl {packageQualificationMetadata = (QMdP d)})) <-
castTS t ->
tell (UnitInterface.singleton d)
- | (Just (LocationDecl {locationQualificationMetadata = (Identity d)})) <-
+ | (Just (LocationDecl {locationQualificationMetadata = (QMdP d)})) <-
castTS t ->
tell (UnitInterface.singleton d)
- | (Just (BitsDecl {bitsQualificationMetadata = (Identity d)})) <-
+ | (Just (BitsDecl {bitsQualificationMetadata = (QMdP d)})) <-
castTS t ->
tell (UnitInterface.singleton d)
- | (Just (ObjTypeDecl {objTypeQualificationMetadata = (Identity d)})) <-
+ | (Just (ObjTypeDecl {objTypeQualificationMetadata = (QMdP d)})) <-
castTS t ->
tell (UnitInterface.singleton d)
- | (Just (ObjectDecl {objectQualificationMetadata = (Identity d)})) <-
+ | (Just (ObjectDecl {objectQualificationMetadata = (QMdP d)})) <-
castTS t ->
tell (UnitInterface.singleton d)
| (Just (ImportStatement {importInterface = ii})) <-
@@ -242,8 +245,9 @@ bitsTypeSize (RegisterBitsArray tr nExpr _) = do
bitsTypeSize
RegisterBitsReference
{ bitsRefQualificationMetadata =
- Identity (ExportedBitsDecl {exportedBitsDeclSizeBits = sz})
+ QMdP (ExportedBitsDecl {exportedBitsDeclSizeBits = sz})
} = return sz
+bitsTypeSize (RegisterBitsReference {}) = error "should be exhaustive"
bitsTypeSize (RegisterBitsJustBits expr _) =
expressionToIntM expr
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 935d8ee..ca97fc4 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -130,14 +130,14 @@ instance AdvanceStage CurrentStage RegisterBitsTypeRef where
ident <-
internAnonymousBitsType path
=<< advanceStage path anonType
- return $ RegisterBitsReference (pure ()) (identToName ident) annot
+ return $ RegisterBitsReference (Identity Vacant) (identToName ident) annot
instance AdvanceStage CurrentStage ObjType where
advanceStage path = \case
(AnonymousObjType _ (Identity body) annot) -> do
body' <- advanceStage path body
identifier <- internObjType path body'
- return (ReferencedObjType (pure ()) (identToName identifier) annot)
+ return (ReferencedObjType (Identity Vacant) (identToName identifier) annot)
(ReferencedObjType q name annot) ->
return $ ReferencedObjType q name annot
(ArrayObjType objType expr a) ->
@@ -197,13 +197,13 @@ reconfigureFiddleDecls p decls = do
where
resolveAnonymousObjType (Linkage linkage, objTypeBody) =
ObjTypeDecl
- (pure ())
+ (Identity Vacant)
(Identifier linkage (annot objTypeBody))
(pure objTypeBody)
(annot objTypeBody)
resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) =
- BitsDecl (pure ()) (Identifier linkage a) (EnumBitType expr body a) a
+ BitsDecl (Identity Vacant) (Identifier linkage a) (EnumBitType expr body a) a
identToName :: Identifier I a -> Name I a
identToName ident = Name (NonEmpty.singleton ident) (annot ident)
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index a39e5dc..0f7158d 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -96,7 +96,7 @@ instance AdvanceStage S RegisterBitsTypeRef where
<$> advanceStage localState a
<*> pure b
RegisterBitsReference _ name a -> do
- v <- fmap snd <$> resolveName name localState
+ v <- fmap (Present . snd) <$> resolveName name localState
return $ RegisterBitsReference v name a
instance AdvanceStage S ObjType where
@@ -107,7 +107,7 @@ instance AdvanceStage S ObjType where
<*> advanceStage localState b
<*> pure c
ReferencedObjType _ name a -> do
- v <- fmap snd <$> resolveName name localState
+ v <- fmap (Present . snd) <$> resolveName name localState
return $ ReferencedObjType v name a
deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t)
@@ -176,6 +176,9 @@ resolveSymbol a (p : ps) (LocalState {ephemeralScope = ephemeralScope, currentSc
resolveSymbol a _ _ =
return $ Left [Diagnostic Error "Empty path provided (this is a bug)" (unCommented a)]
+qMd :: (Applicative f) => t -> f (QMd Qualified t)
+qMd = pure . Present
+
advanceFiddleDecls ::
LocalState ->
[Directed FiddleDecl S F A] ->
@@ -213,7 +216,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
insertDecl decl
doReturn
=<< PackageDecl
- (pure decl)
+ (qMd decl)
name
<$> mapM (advanceStage localState'') body
<*> pure ann
@@ -228,7 +231,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
insertDecl decl
doReturn
=<< LocationDecl
- (pure decl)
+ (qMd decl)
ident
<$> advanceStage localState' expr
<*> pure ann
@@ -243,7 +246,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
insertDecl decl
doReturn
=<< BitsDecl
- (pure decl)
+ (qMd decl)
ident
<$> advanceStage localState' typ
<*> pure ann
@@ -258,7 +261,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
insertDecl decl
doReturn
=<< ObjTypeDecl
- (pure decl)
+ (qMd decl)
ident
<$> mapM (advanceStage localState') body
<*> pure ann
@@ -275,7 +278,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
insertDecl decl
doReturn
=<< ObjectDecl
- (pure decl)
+ (qMd decl)
ident
<$> advanceStage localState' loc
<*> advanceStage localState' typ
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 694b3ab..9b04ac7 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -31,14 +31,7 @@ type Context stage =
( Show (NumberType stage),
Typeable stage,
ToJSON (NumberType stage),
- ToJSON (RegisterOffset 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)
+ ToJSON (RegisterOffset stage)
)
class FunctorShow f where
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index f3cbfee..ebc3d8d 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -30,6 +30,9 @@ type Pa (a :: Stage -> (Type -> Type) -> Type -> Type) = P (a 'Parsed F (Comment
type PaS (a :: (Type -> Type) -> Type -> Type) = P (a F (Commented SourceSpan))
+noQMd :: F (QMd Parsed t)
+noQMd = pure Vacant
+
commentP :: P Comment
commentP =
token $ \case
@@ -139,15 +142,15 @@ fiddleDeclP = do
case t of
KWOption -> OptionDecl <$> nextTextP <*> nextTextP
KWPackage ->
- PackageDecl (pure ())
+ PackageDecl noQMd
<$> name
<*> defer body packageBodyP
KWUsing -> UsingDecl Witness <$> name
- KWLocation -> LocationDecl (pure ()) <$> ident <*> (tok TokEq >> expressionP)
- KWBits -> BitsDecl (pure ()) <$> ident <*> (tok TokColon >> bitTypeP)
+ KWLocation -> LocationDecl noQMd <$> ident <*> (tok TokEq >> expressionP)
+ KWBits -> BitsDecl noQMd <$> ident <*> (tok TokColon >> bitTypeP)
KWImport -> ImportDecl <$> importStatementP
KWType ->
- ObjTypeDecl (pure ())
+ ObjTypeDecl noQMd
<$> ident
<*> ( do
tok_ TokColon
@@ -155,7 +158,7 @@ fiddleDeclP = do
defer body (objTypeBodyP bt)
)
KWInstance ->
- ObjectDecl (pure ())
+ ObjectDecl noQMd
<$> ident
<*> (tok KWAt *> expressionP)
<*> (tok TokColon *> objTypeP)
@@ -181,7 +184,7 @@ objTypeP = do
baseObjP :: P (A -> ObjType Parsed F A)
baseObjP =
- (ReferencedObjType (pure ()) <$> name)
+ (ReferencedObjType noQMd <$> name)
<|> ( do
t <- bodyTypeP
AnonymousObjType Witness <$> defer body (objTypeBodyP t)
@@ -281,7 +284,7 @@ registerBitsTypeRefP = do
withMeta $
(RegisterBitsJustBits <$> exprInParenP)
<|> (RegisterBitsAnonymousType Witness <$> anonymousBitsTypeP)
- <|> (RegisterBitsReference (pure ()) <$> name)
+ <|> (RegisterBitsReference noQMd <$> name)
anonymousBitsTypeP :: Pa AnonymousBitsType
anonymousBitsTypeP = withMeta $ do
generated by cgit (git 2.34.1) at 2025-04-28 22:35:16 +0000