summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--goal.fiddle2
-rw-r--r--src/Language/Fiddle/Ast.hs1
-rw-r--r--src/Language/Fiddle/Ast/Internal/Instances.hs10
-rw-r--r--src/Language/Fiddle/Ast/Internal/Instances/Walk.hs10
-rw-r--r--src/Language/Fiddle/Ast/Internal/SyntaxTree.hs38
-rw-r--r--src/Language/Fiddle/Compiler.hs43
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs839
-rw-r--r--src/Language/Fiddle/Compiler/Expansion.hs16
-rw-r--r--src/Language/Fiddle/Compiler/ImportResolution.hs5
-rw-r--r--src/Language/Fiddle/Compiler/Qualification.hs330
-rw-r--r--src/Language/Fiddle/GenericTree.hs30
-rw-r--r--src/Language/Fiddle/Internal/Scopes.hs48
-rw-r--r--src/Language/Fiddle/Internal/UnitInterface.hs171
-rw-r--r--src/Language/Fiddle/Parser.hs28
-rw-r--r--src/Language/Fiddle/Types.hs11
15 files changed, 837 insertions, 745 deletions
diff --git a/goal.fiddle b/goal.fiddle
index a7f43f0..8b8a93b 100644
--- a/goal.fiddle
+++ b/goal.fiddle
@@ -131,7 +131,7 @@ package stm32l4.gpio {
assert_pos(0x12);
wo reg alt_r2(8);
- reserved(8);
+ reserved(1);
};
};
assert_pos(0x14);
diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs
index a6ea87a..f5fbafe 100644
--- a/src/Language/Fiddle/Ast.hs
+++ b/src/Language/Fiddle/Ast.hs
@@ -8,3 +8,4 @@ import Language.Fiddle.Ast.Internal.Instances as X
import Language.Fiddle.Ast.Internal.Kinds as X
import Language.Fiddle.Ast.Internal.Stage as X
import Language.Fiddle.Ast.Internal.SyntaxTree as X
+import Language.Fiddle.Ast.Internal.Util as X
diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs
index 232d5c0..aaa20b8 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances.hs
@@ -120,8 +120,8 @@ class
stage
( t
(StageAfter stage) -- The next stage in the pipeline
- (StageFunctor stage) -- The functor associated with the next stage
- (StageAnnotation stage) -- Annotation type for the next stage
+ (StageFunctor stage) -- The functor associated with this stage
+ (StageAnnotation stage) -- Annotation type for this stage
)
-- | Default implementation of 'advanceStage' using generics. This leverages
@@ -311,6 +311,12 @@ instance
K1 <$> ffn newK
instance
+ (Traversable f1) =>
+ GAlter t f1 f2 a1 a2 (Rec0 (f1 x)) (Rec0 (f2 x))
+ where
+ galter _ ffn _ (K1 k) = K1 <$> ffn k
+
+instance
( GAlter t f1 f2 a1 a2 l1 l2,
GAlter t f1 f2 a1 a2 r1 r2
) =>
diff --git a/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs b/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs
index d80963d..221dd5b 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs
@@ -1,8 +1,16 @@
-module Language.Fiddle.Ast.Internal.Instances.Walk (Walk (..), GWalk (..)) where
+module Language.Fiddle.Ast.Internal.Instances.Walk (Walk (..), GWalk (..), walk_) where
import Data.Typeable
import GHC.Generics
+-- | Like walk, but assumes no local state.
+walk_ ::
+ (Monad m, Traversable f, Typeable f, Typeable a, Walk t) =>
+ (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> m ()) ->
+ t f a ->
+ m ()
+walk_ fn t = walk (\t _ -> fn t) t ()
+
class (Typeable t) => Walk t where
walk ::
(Monad m, Traversable f, Typeable f, Typeable a) =>
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 8e3cd6c..73c4303 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -12,6 +12,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
ImportInterface,
FiddleUnitInterface,
QualificationMetadata,
+ CommonQualificationData (..),
-- Witness Types
Witness (..),
WitnessType,
@@ -48,18 +49,13 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
mapDirectedM,
asDirected,
undirected,
- -- Utility Functions
- squeeze,
- nameToList,
)
where
import Control.Monad (forM_)
-import Data.Functor.Identity
import Data.Kind (Type)
import Data.List.NonEmpty hiding (map)
import Data.Text (Text)
-import qualified Data.Text as Text
import Data.Type.Bool
import Data.Typeable
import Data.Void (Void)
@@ -67,11 +63,11 @@ import GHC.Generics
import Language.Fiddle.Ast.Internal.Instances
import Language.Fiddle.Ast.Internal.Kinds
import Language.Fiddle.Ast.Internal.Stage
-import Language.Fiddle.Internal.UnitInterface (UnitInterface)
+import Language.Fiddle.Internal.UnitInterface
-- | Common data for each qualified element.
-newtype CommonQualifcationData
- = CommonQualifcationData
+newtype CommonQualificationData
+ = CommonQualificationData
{ -- The fully qualified path to this qualified element.
fullyQualifiedPath :: [String]
}
@@ -79,7 +75,7 @@ newtype CommonQualifcationData
type family QualificationMetadata stage t where
QualificationMetadata stage t =
- If (stage < Qualified) () (CommonQualifcationData, t)
+ If (stage < Qualified) () t
-- | The type attached to import statements which describe the imported file's
-- unit interface
@@ -278,7 +274,7 @@ data Expression (s :: Stage) :: SynTree where
-- | A variable reference.
Var ::
{ -- | The identifier of the variable.
- varIdentifier :: Identifier f a,
+ varIdentifier :: Name f a,
-- | Annotation for the variable.
varAnnot :: a
} ->
@@ -348,7 +344,8 @@ data FiddleDecl :: StagedSynTree where
-- | A package declaration.
PackageDecl ::
{ -- | Qualification metadata about this package statement.
- packageQualificationMetadata :: QualificationMetadata stage (),
+ packageQualificationMetadata ::
+ f (QualificationMetadata stage ExportedPackageDecl),
-- | The package name.
packageName :: Name f a,
-- | The body of the package.
@@ -360,7 +357,8 @@ data FiddleDecl :: StagedSynTree where
-- | A location declaration in the form 'location <identifier> = <expr>'.
LocationDecl ::
{ -- | qualified metadata about this location.
- locationQualificationMetadata :: QualificationMetadata stage (),
+ locationQualificationMetadata ::
+ f (QualificationMetadata stage ExportedLocationDecl),
-- | The location identifier.
locationIdent :: Identifier f a,
-- | The associated expression.
@@ -372,7 +370,7 @@ data FiddleDecl :: StagedSynTree where
-- | A bits declaration in the form 'bits <identifier> : <type>'.
BitsDecl ::
{ -- | Qualification metadata about this "bits" declaration.
- bitsQualificationMetadata :: QualificationMetadata stage (),
+ bitsQualificationMetadata :: f (QualificationMetadata stage ExportedBitsDecl),
-- | The identifier of the bits.
bitsIdent :: Identifier f a,
-- | The type of the bits.
@@ -384,7 +382,7 @@ data FiddleDecl :: StagedSynTree where
-- | An object type declaration.
ObjTypeDecl ::
{ -- | Qualification metadata about this object type.
- objTypeQualificationMetadata :: QualificationMetadata stage (),
+ objTypeQualificationMetadata :: f (QualificationMetadata stage ExportedTypeDecl),
-- | The identifier of the object type.
objTypeIdent :: Identifier f a,
-- | The body of the object type.
@@ -396,7 +394,7 @@ data FiddleDecl :: StagedSynTree where
-- | An object declaration in the form 'object <ident> at <expr> : <type>'.
ObjectDecl ::
{ -- | Qualification metadata about this object.
- objectQualificationMetadata :: QualificationMetadata stage (),
+ objectQualificationMetadata :: f (QualificationMetadata stage ExportedObjectDecl),
-- | The identifier of the object.
objectIdent :: Identifier f a,
-- | The location expression.
@@ -448,7 +446,7 @@ data ObjType stage f a where
ObjType stage f a
-- | A reference to an existing type by name.
ReferencedObjType ::
- { refQualificationMetadata :: QualificationMetadata stage (),
+ { refQualificationMetadata :: f (QualificationMetadata stage ExportedTypeDecl),
-- | The name of the referenced type.
refName :: Name f a,
-- | Annotation for the referenced type.
@@ -609,7 +607,7 @@ data RegisterBitsTypeRef stage f a where
-- | A reference to another type by name.
RegisterBitsReference ::
{ -- | Qualification metadata about this Bits reference.
- bitsRefQualificationMetadata :: QualificationMetadata stage (),
+ bitsRefQualificationMetadata :: f (QualificationMetadata stage ExportedBitsDecl),
-- | The name of the referenced type.
bitsRefName :: Name f a,
-- | Annotation for the reference.
@@ -714,9 +712,3 @@ data PackageBody (stage :: Stage) (f :: Type -> Type) a where
} ->
PackageBody stage f a
deriving (Generic, Annotated, Typeable, Alter, Walk)
-
-squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a)
-squeeze = alter (fmap Identity) return
-
-nameToList :: Name f a -> [String]
-nameToList (Name ids _) = map (Text.unpack . identifierName) (toList ids)
diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs
index c029765..049d533 100644
--- a/src/Language/Fiddle/Compiler.hs
+++ b/src/Language/Fiddle/Compiler.hs
@@ -6,6 +6,7 @@ module Language.Fiddle.Compiler where
import Control.Arrow
import Control.Monad (when)
+import Control.Monad.Identity (Identity)
import Control.Monad.RWS
import Control.Monad.Trans.Maybe
import Control.Monad.Writer
@@ -21,6 +22,15 @@ data Level = Error | Warning | Info
data Diagnostic = Diagnostic Level String SourceSpan
+emitDiagnosticError :: String -> Commented SourceSpan -> Compile a ()
+emitDiagnosticError str a = tell [Diagnostic Error str (unCommented a)]
+
+emitDiagnosticWarning :: String -> Commented SourceSpan -> Compile a ()
+emitDiagnosticWarning str a = tell [Diagnostic Warning str (unCommented a)]
+
+emitDiagnosticInfo :: String -> Commented SourceSpan -> Compile a ()
+emitDiagnosticInfo str a = tell [Diagnostic Info str (unCommented a)]
+
newtype Compile s a = Compile (MaybeT (RWS () [Diagnostic] s) a)
deriving newtype (Functor, Applicative, Monad)
@@ -103,13 +113,13 @@ pureCompilationPhase ::
(CompilationStage stageFrom) =>
( FiddleUnit
stageFrom
- (StageFunctor stageFrom)
+ Identity
(StageAnnotation stageFrom) ->
Compile
()
( FiddleUnit
stageTo
- (StageFunctor stageTo)
+ Identity
(StageAnnotation stageTo)
)
) ->
@@ -138,7 +148,7 @@ data CompilationPhase stageFrom stageTo where
-- only time a side effect may be performed.
ioAction ::
privateFlags ->
- TreeType FiddleUnit Parsed ->
+ FiddleUnit Parsed Identity (StageAnnotation Parsed) ->
IO ([Diagnostic], Maybe privateState),
-- | 'nextStage' is the function that transforms a 'FiddleUnit' from
-- the current stage ('stageFrom') to the next stage ('stageTo'). It
@@ -149,13 +159,13 @@ data CompilationPhase stageFrom stageTo where
privateState ->
FiddleUnit
stageFrom
- (StageFunctor stageFrom)
+ Identity
(StageAnnotation stageFrom) ->
Compile
()
( FiddleUnit
stageTo
- (StageFunctor stageTo)
+ Identity
(StageAnnotation stageTo)
)
} ->
@@ -198,11 +208,11 @@ thenPhase
execCompilationPipelineWithCmdline ::
CompilationPhase Parsed s' ->
Parser
- ( FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) ->
+ ( FiddleUnit Parsed Identity (StageAnnotation Parsed) ->
IO
( [Diagnostic],
Maybe
- ( FiddleUnit s' (StageFunctor s') (StageAnnotation s')
+ ( FiddleUnit s' Identity (StageAnnotation s')
)
)
)
@@ -216,3 +226,22 @@ execCompilationPipelineWithCmdline
Nothing -> return (diags, Nothing)
)
flagsParser
+
+squeezeDiagnostics :: (Alter t) => t (Either [Diagnostic]) a -> Compile () (t Identity a)
+squeezeDiagnostics ast = do
+ _ <-
+ alter
+ ( \case
+ (Left l) -> tell l >> return (Left l)
+ r -> return r
+ )
+ return
+ ast
+
+ case squeeze ast of
+ (Left _) -> compilationFailure
+ (Right a) -> return a
+
+resolveOrFail :: Either [Diagnostic] a -> Compile s a
+resolveOrFail (Right a) = return a
+resolveOrFail (Left l) = tell l >> compilationFailure
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 3bdae4a..410f3e2 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -2,636 +2,283 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE IncoherentInstances #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}
-module Language.Fiddle.Compiler.ConsistencyCheck
- ( checkConsistency,
- consistencyCheckPhase,
- )
-where
+module Language.Fiddle.Compiler.ConsistencyCheck (consistencyCheckPhase) where
-import Control.Monad (forM_, unless, when)
-import Control.Monad.RWS (MonadState (get, put), MonadWriter (tell), gets, modify')
-import Data.Foldable (foldlM)
+import Control.Monad (forM_, when)
+import Control.Monad.RWS (MonadWriter (tell))
+import Control.Monad.Trans.Writer (Writer, execWriter)
+import Data.Foldable (foldlM, toList)
import Data.Functor.Identity
-import Data.List (intercalate)
-import Data.Maybe (mapMaybe)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Typeable
import Data.Word (Word32)
import GHC.TypeError as TypeError
import Language.Fiddle.Ast
import Language.Fiddle.Compiler
-import Language.Fiddle.Internal.Scopes
import Language.Fiddle.Internal.UnitInterface as UnitInterface
-import Language.Fiddle.Types (Comment (DocComment), Commented (Commented, unCommented), SourceSpan)
-import Prelude hiding (unzip)
+import Language.Fiddle.Types
import Text.Printf (printf)
+import Prelude hiding (unzip)
-import qualified Data.IntMap as IntMap
-import qualified Data.List.NonEmpty as NonEmpty
-import qualified Data.Text as Text
-
-data GlobalState = GlobalState
- { globalScope :: Scope String (Either SizeBits SizeBytes),
- _fileDependencies :: [FilePath],
- unitInterface :: UnitInterface
- }
-
-newtype LocalState = LocalState (ScopePath String)
-
-type CurrentStage = Qualified
-
-type I = Identity
-
-type Annot = Commented SourceSpan
+type S = Qualified
-type SizeBits = Word32
+type S' = Checked
-type SizeBytes = Word32
+type F = Identity
-consistencyCheckPhase :: CompilationPhase CurrentStage Checked
-consistencyCheckPhase = pureCompilationPhase checkConsistency
+type A = Commented SourceSpan
-checkConsistency ::
- FiddleUnit CurrentStage I Annot ->
- Compile () (FiddleUnit Checked I Annot)
-checkConsistency =
- fmap snd
- . subCompile (GlobalState mempty mempty mempty)
- . advanceStage (LocalState mempty)
+type M = Compile ()
instance CompilationStage Checked where
type StageAfter Checked = TypeError (TypeError.Text "No stage after Checked")
- type StageMonad Checked = Compile GlobalState
- type StageState Checked = LocalState
+ type StageMonad Checked = M
+ type StageState Checked = ()
type StageFunctor Checked = Identity
- type StageAnnotation Checked = Commented SourceSpan
-
-instance CompilationStage CurrentStage where
- type StageAfter CurrentStage = Checked
- type StageMonad CurrentStage = Compile GlobalState
- type StageState CurrentStage = LocalState
- type StageFunctor CurrentStage = Identity
- type StageAnnotation CurrentStage = Commented SourceSpan
-
-instance AdvanceStage CurrentStage FiddleUnit where
- advanceStage localState (FiddleUnit _ decls a) = do
- decls' <- mapM (advanceStage localState) decls
- intf <- gets unitInterface
- return $ FiddleUnit intf decls' a
+ type StageAnnotation Checked = A
--- advanceStage localState (FiddleUnit decls _ annot) = do
+instance CompilationStage S where
+ type StageAfter S = S'
+ type StageMonad S = M
+ type StageState S = ()
+ type StageFunctor S = F
+ type StageAnnotation S = A
--- decls' <- mapM (advanceStage localState) decls
+consistencyCheckPhase :: CompilationPhase S S'
+consistencyCheckPhase = pureCompilationPhase $ advanceStage ()
-deriving instance AdvanceStage CurrentStage Expression
+instance AdvanceStage S ObjTypeBody where
+ advanceStage () objTypeBody = snd <$> advanceObjTypeBody objTypeBody 0
-deriving instance AdvanceStage CurrentStage ObjType
+deriving instance AdvanceStage S DeferredRegisterBody
-deriving instance AdvanceStage CurrentStage DeferredRegisterBody
+deriving instance AdvanceStage S RegisterBody
-deriving instance AdvanceStage CurrentStage RegisterBitsDecl
+deriving instance AdvanceStage S AnonymousBitsType
-deriving instance AdvanceStage CurrentStage RegisterBitsTypeRef
+deriving instance AdvanceStage S ImportStatement
-deriving instance AdvanceStage CurrentStage AnonymousBitsType
+deriving instance AdvanceStage S BitType
-deriving instance AdvanceStage CurrentStage BitType
+deriving instance AdvanceStage S EnumBody
-deriving instance AdvanceStage CurrentStage EnumBody
+deriving instance AdvanceStage S EnumConstantDecl
-deriving instance AdvanceStage CurrentStage EnumConstantDecl
+deriving instance AdvanceStage S RegisterBitsDecl
-deriving instance AdvanceStage CurrentStage PackageBody
+deriving instance AdvanceStage S PackageBody
-instance AdvanceStage CurrentStage ImportStatement where
- modifyState
- ( ImportStatement
- { importInterface =
- ( UnitInterface
- { rootScope = unitScope,
- dependencies = importDependencies
- }
- )
- }
- )
- ls = do
- modify'
- ( \s@GlobalState
- { globalScope = globalScope,
- unitInterface = unitInterface
- } ->
- s
- { globalScope =
- unitInterfaceScopeToGlobalScope unitScope <> globalScope,
- unitInterface =
- unitInterface
- { dependencies =
- importDependencies ++ dependencies unitInterface
- }
- }
- )
- return ls
- where
- unitInterfaceScopeToGlobalScope =
- fmap
- ( \(_, exportedValue) -> case exportedValue of
- ExportedBitsType sz -> Left sz
- ExportedObjType sz -> Right sz
- )
-
-deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t)
-
-instance AdvanceStage CurrentStage RegisterBody where
- advanceStage s body = fst <$> registerBodyToStage3 s body
-
-instance AdvanceStage CurrentStage ObjTypeBody where
- advanceStage s body = fst <$> objTypeBodyToStage3 s body 0
-
-deriving instance AdvanceStage CurrentStage FiddleDecl
-
-instance AdvanceStage CurrentStage (Directed FiddleDecl) where
- modifyState (Directed _ t _) s = case t of
- (BitsDecl _ id typ annotation) -> do
- typeSize <- getTypeSize typ
- insertTypeSize annotation s id typeSize
- return s
- (PackageDecl _ n _ _) -> do
- let strs = nameToList n
- let (LocalState scopePath) = s
-
- return $
- LocalState $
- scopePath {currentScope = strs ++ currentScope scopePath}
- (UsingDecl _ n _) ->
- let (LocalState scopePath) = s
- in return $
- LocalState $
- scopePath
- { usingPaths = nameToList n : usingPaths scopePath
- }
- _ -> return s
-
- customAdvanceStage (Directed directives t a) (LocalState scopePath) = case t of
- (ObjTypeDecl q ident (Identity body) annot) -> do
- (body', size) <- objTypeBodyToStage3 (LocalState scopePath) body 0
-
- let fullName =
- NonEmpty.prependList
- (currentScope scopePath)
- (NonEmpty.singleton (Text.unpack (identifierName ident)))
-
- ui <- gets unitInterface
- let ui' = insertIntoUnitInterface fullName ui annot (ExportedObjType size)
- modify' $ \gs -> gs {unitInterface = ui'}
-
- return $ Just $ Directed directives (ObjTypeDecl q ident (Identity body') annot) a
- _ -> return Nothing
-
-objTypeBodyToStage3 ::
- LocalState ->
- ObjTypeBody CurrentStage I Annot ->
- Word32 ->
- Compile GlobalState (ObjTypeBody Checked I Annot, Word32)
-objTypeBodyToStage3 st (ObjTypeBody bodyType decls a) startOff = do
- let isUnion = case bodyType of
- Union {} -> True
- _ -> False
- (cur, returned) <-
- foldlM
- ( \(cursor, returned) decl ->
- case undirected decl of
- RegisterDecl mMod mIdent expr mBody a -> do
- (s3RegisterBody, mCalculatedSize) <-
- fUnzip <$> mapM (registerBodyToStage3 st) mBody
-
- nExpr <- advanceStage st expr
-
- let s3 =
- mapDirected
- ( const $
- RegisterDecl
- mMod
- mIdent
- nExpr
- s3RegisterBody
- a
- )
- decl
-
- declaredSizeBits <- fromIntegral <$> exprToSize expr
-
- when ((declaredSizeBits `mod` 8) /= 0) $
- tell
- [ Diagnostic
- Error
- "Register size is not a multiple of 8. Please pad register size to align with 8. "
- (unCommented a)
- ]
-
- forM_ mCalculatedSize $ \(fromIntegral -> calculatedSize) ->
- unless (calculatedSize == declaredSizeBits) $
- let helpful =
- if calculatedSize < declaredSizeBits
- then
- printf
- "\nPerhaps you should add 'reserved(%d)' to the end of your register declaration?"
- (declaredSizeBits - calculatedSize)
- else ""
- in tell
- [ Diagnostic
- Error
- ( printf
- "Calculated size %d does not match declared size %d.%s"
- calculatedSize
- declaredSizeBits
- helpful
- )
- (unCommented a)
- ]
-
- if isUnion
- then
- checkUnion cursor (declaredSizeBits `div` 8) (s3 : returned) a
- else
- return (cursor + declaredSizeBits `div` 8, s3 : returned)
- TypeSubStructure (Identity subBody) maybeIdent annot -> do
- (newBody, size) <-
- objTypeBodyToStage3
- st
- subBody
- ( if isUnion then startOff else cursor
- )
- let s3 = mapDirected (const $ TypeSubStructure (Identity newBody) maybeIdent annot) decl
-
- checkTypesSubStructure subBody maybeIdent annot
- if isUnion
- then
- checkUnion cursor size (s3 : returned) a
- else
- return (cursor + size, s3 : returned)
- ReservedDecl expr annot -> do
- size' <- fromIntegral <$> exprToSize expr
- when ((size' `mod` 8) /= 0) $
- tell
- [ Diagnostic
- Error
- "Can only reserve a multiple of 8 bits in this context."
- (unCommented a)
- ]
-
- expr' <- advanceStage st expr
- let size = size' `div` 8
- let s3 = mapDirected (const $ ReservedDecl expr' annot) decl
- if isUnion
- then
- checkUnion cursor size (s3 : returned) a
- else
- return (cursor + size, s3 : returned)
- AssertPosStatement _ expr a -> do
- declaredPos <- fromIntegral <$> exprToSize expr
-
- let expectedPos = if isUnion then startOff else cursor + startOff
-
- when (expectedPos /= declaredPos) $ do
- tell
- [ Diagnostic
- Error
- ( printf
- "Position assertion failed. Asserted 0x%x, calculated 0x%x"
- declaredPos
- expectedPos
- )
- (unCommented a)
- ]
- return (cursor, returned)
- )
- (0, [])
- decls
+deriving instance AdvanceStage S FiddleDecl
- return (ObjTypeBody bodyType (reverse returned) a, cur)
- where
- checkTypesSubStructure
- (ObjTypeBody bodyType decls _)
- maybeIdent
- annot =
- let emitWarning s = tell [Diagnostic Warning s (unCommented annot)]
- in case () of
- ()
- | [_] <- decls,
- (Union {}) <- bodyType ->
- emitWarning "Union with a single field. Should this be a struct?"
- ()
- | [_] <- decls,
- (Struct {}) <- bodyType,
- Nothing <- maybeIdent ->
- emitWarning "Anonymous sub-struct with single field is superfluous."
- ()
- | [] <- decls ->
- emitWarning
- ( printf
- "Empty sub-%s is superfluous."
- ( case bodyType of
- Union {} -> "union"
- Struct {} -> "struct"
- )
- )
- _ -> return ()
- fUnzip xs = (fst <$> xs, snd <$> xs)
-
-registerBodyToStage3 ::
- LocalState ->
- RegisterBody CurrentStage I Annot ->
- Compile GlobalState (RegisterBody Checked I Annot, Word32)
-registerBodyToStage3
- st
- (RegisterBody bodyType (Identity deferredRegisterBody) a') = do
- let isUnion = case bodyType of
- Union {} -> True
- _ -> False
-
- case deferredRegisterBody of
- DeferredRegisterBody decls a -> do
- (cur, returned) <-
- foldlM
- ( \(cursor, returned) decl ->
- case undirected decl of
- ReservedBits expr a -> do
- size <- fromIntegral <$> exprToSize expr
- expr' <- advanceStage st expr
- let s3 =
- mapDirected
- (const $ ReservedBits expr' a)
- decl
- if isUnion
- then checkUnion cursor size (s3 : returned) a
- else
- return (cursor + size, s3 : returned)
- BitsSubStructure registerBody maybeIdent annot -> do
- checkBitsSubStructure registerBody maybeIdent annot
-
- (newBody, subsize) <- registerBodyToStage3 st registerBody
- let s3 =
- mapDirected
- (const $ BitsSubStructure newBody maybeIdent annot)
- decl
-
- if isUnion
- then checkUnion cursor subsize (s3 : returned) a
- else
- return (cursor + subsize, s3 : returned)
- DefinedBits modifier identifier typeref a -> do
- (s3TypeRef, size) <- registerBitsTypeRefToStage3 st typeref
- let s3 =
- mapDirected
- (const $ DefinedBits modifier identifier s3TypeRef a)
- decl
-
- if isUnion
- then checkUnion cursor size (s3 : returned) a
- else
- return (cursor + size, s3 : returned)
- )
- (0, [])
- decls
-
- return
- ( RegisterBody
- bodyType
- (Identity (DeferredRegisterBody (reverse returned) a))
- a',
- cur
- )
+instance AdvanceStage S FiddleUnit where
+ advanceStage () fu@(FiddleUnit _ decls a) =
+ FiddleUnit (getUnitInterface fu) <$> mapM (advanceStage ()) decls <*> pure a
where
- checkBitsSubStructure
- (RegisterBody bodyType (Identity (DeferredRegisterBody decls _)) _)
- maybeIdent
- annot =
- let emitWarning s = tell [Diagnostic Warning s (unCommented annot)]
- in case () of
- ()
- | [_] <- decls,
- (Union {}) <- bodyType ->
- emitWarning "Union with a single field. Should this be a struct?"
- ()
- | [_] <- decls,
- (Struct {}) <- bodyType,
- Nothing <- maybeIdent ->
- emitWarning "Anonymous sub-struct with single field is superfluous."
- ()
- | [] <- decls ->
- emitWarning
- ( printf
- "Empty sub-%s is superfluous."
- ( case bodyType of
- Union {} -> "union"
- Struct {} -> "struct"
- )
- )
- _ -> return ()
-
-registerBitsTypeRefToStage3 ::
- LocalState ->
- RegisterBitsTypeRef CurrentStage I Annot ->
- Compile GlobalState (RegisterBitsTypeRef Checked I Annot, Word32)
-registerBitsTypeRefToStage3 localState = \case
- RegisterBitsArray ref expr a -> do
- (ref', size) <- registerBitsTypeRefToStage3 localState ref
- multiplier <- exprToSize expr
- expr' <- advanceStage localState expr
- return
- ( RegisterBitsArray ref' expr' a,
- size * fromIntegral multiplier
- )
- RegisterBitsReference q name a ->
- (RegisterBitsReference q name a,) <$> lookupTypeSize localState name
- RegisterBitsJustBits expr a -> do
- expr' <- advanceStage localState expr
- (RegisterBitsJustBits expr' a,)
- . fromIntegral
- <$> exprToSize expr
-
-checkUnion :: Word32 -> Word32 -> b -> Commented SourceSpan -> Compile s (Word32, b)
-checkUnion cursor subsize ret a = do
- when (cursor /= 0 && subsize /= cursor) $ do
- tell
- [ Diagnostic
- Warning
- ( printf
- "Jagged union found. Found size %d, expected %d.\n \
- \ Please wrap smaller fields in a struct with padding so all \
- \ fields are the same size?"
- subsize
- cursor
- )
- (unCommented a)
- ]
- return (max cursor subsize, ret)
-
-exprToSize ::
- (NumberType stage ~ Integer) =>
- Expression stage I Annot ->
- Compile s Integer
-exprToSize (LitNum num _) = return num
-exprToSize e = do
- tell [Diagnostic Error "Variables not allowed" (unCommented $ annot e)]
- compilationFailure
-
-lookupTypeSize :: LocalState -> Name I Annot -> Compile GlobalState SizeBits
-lookupTypeSize (LocalState scopePath) (Name idents a) = do
- -- Convert the list of identifiers to a string path
- let path = fmap (\(Identifier s _) -> Text.unpack s) idents
-
- -- Get the current scope and perform the lookup
- results <- gets $ lookupScopeWithPath scopePath path . globalScope
-
- case results of
- -- Successfully resolved to a unique size
- [(_, Left sz)] -> return sz
- -- Multiple ambiguous results found
- matches@(_ : _ : _) -> do
- -- Generate a list of ambiguous paths for error reporting
- let ambiguousPaths =
- map
- ( \(resolvedPath, _) ->
- intercalate "." (NonEmpty.toList resolvedPath)
- )
- matches
- tell
- [ Diagnostic
- Error
- ( printf
- "Ambiguous occurrence of '%s'. Multiple matches found:\n%s"
- (intercalate "." $ NonEmpty.toList path)
- (unlines ambiguousPaths) -- List all ambiguous paths
- )
- (unCommented a)
- ]
- compilationFailure
-
- -- No matches found
- [] -> do
- tell
- [ Diagnostic
- Error
- ( printf
- "Cannot resolve '%s'. No matching symbols found."
- (intercalate "." $ NonEmpty.toList path)
- )
- (unCommented a)
- ]
- compilationFailure
- _ -> compilationFailure
-
-getTypeSize :: BitType CurrentStage I Annot -> Compile s SizeBits
-getTypeSize (RawBits expr _) = fromIntegral <$> exprToSize expr
-getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
- declaredSize <- fromIntegral <$> exprToSize expr
-
- -- If the declared size is less than or equal to 4, we'll enforce that the
- -- enum is packed. This is to make sure the user has covered all bases.
- when (declaredSize <= 4) $ do
- imap <-
+ getUnitInterface = execWriter . walk_ doWalk
+
+ doWalk :: forall t'. (Walk t', Typeable t') => t' F A -> Writer UnitInterface ()
+ doWalk t =
+ case () of
+ ()
+ | (Just (PackageDecl {packageQualificationMetadata = (Identity d)})) <-
+ castTS t ->
+ tell (UnitInterface.singleton d)
+ | (Just (LocationDecl {locationQualificationMetadata = (Identity d)})) <-
+ castTS t ->
+ tell (UnitInterface.singleton d)
+ | (Just (BitsDecl {bitsQualificationMetadata = (Identity d)})) <-
+ castTS t ->
+ tell (UnitInterface.singleton d)
+ | (Just (ObjTypeDecl {objTypeQualificationMetadata = (Identity d)})) <-
+ castTS t ->
+ tell (UnitInterface.singleton d)
+ | (Just (ObjectDecl {objectQualificationMetadata = (Identity d)})) <-
+ castTS t ->
+ tell (UnitInterface.singleton d)
+ | (Just (ImportStatement {importInterface = ii})) <-
+ castTS t ->
+ tell (UnitInterface mempty (dependencies ii))
+ _ -> return ()
+
+ castTS ::
+ (Typeable t', Typeable t, Typeable f, Typeable a) =>
+ t' f a ->
+ Maybe (t S f a)
+ castTS = cast
+
+deriving instance AdvanceStage S Expression
+
+deriving instance AdvanceStage S RegisterBitsTypeRef
+
+deriving instance AdvanceStage S ObjType
+
+deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t)
+
+advanceObjTypeBody :: ObjTypeBody S F A -> Word32 -> M (Word32, ObjTypeBody S' F A)
+advanceObjTypeBody (ObjTypeBody us decls a) startOffset = do
+ (decls', _) <- advanceDecls
+
+ calcSize <- case us of
+ Union {} -> do
+ checkJagged decls'
+ return $ maximum (map fst decls')
+ Struct {} -> return $ sum (map fst decls')
+
+ return (calcSize, ObjTypeBody us (reverse $ map snd decls') a)
+ where
+ advanceDecls :: M ([(Word32, Directed ObjTypeDecl S' F A)], Word32)
+ advanceDecls = do
foldlM
- ( \imap (undirected -> enumConst) -> do
- number <- case enumConst of
- EnumConstantDecl _ expr _ -> exprToSize expr
- EnumConstantReserved expr _ -> exprToSize expr
-
- when (number >= 2 ^ declaredSize) $
- tell
- [ Diagnostic
- Error
- ( printf
- "Enum constant too large. Max allowed %d\n"
- ((2 :: Int) ^ declaredSize)
- )
- (unCommented (annot enumConst))
- ]
-
- return $ IntMap.insert (fromIntegral number) True imap
+ ( \(ret, offset) d ->
+ let advanceOffset = case us of
+ Union {} -> const
+ Struct {} -> (+)
+ doReturn x size = return ((size, mapDirected (const x) d) : ret, advanceOffset offset size)
+ in case undirected d of
+ e@AssertPosStatement {assertExpr = expr} -> do
+ assertedPos <- expressionToIntM expr
+ checkPositionAssertion (annot e) assertedPos offset
+ return (ret, offset)
+ (RegisterDecl mod ident size Nothing a) -> do
+ (sizeExpr, reifiedSize) <- advanceAndGetSize size
+ doReturn (RegisterDecl mod ident sizeExpr Nothing a)
+ =<< checkBitsSizeMod8 a reifiedSize
+ (RegisterDecl mod ident size (Just body) a) -> do
+ declaredSize <- expressionToIntM size
+ (actualSize, body') <- advanceRegisterBody body
+ checkSizeMismatch a declaredSize actualSize
+ (sizeExpr, reifiedSize) <- advanceAndGetSize size
+ doReturn (RegisterDecl mod ident sizeExpr (Just body') a)
+ =<< checkBitsSizeMod8 a reifiedSize
+ (ReservedDecl size a) -> do
+ (sizeExpr, reifiedSize) <- advanceAndGetSize size
+ doReturn (ReservedDecl sizeExpr a) reifiedSize
+ (TypeSubStructure (Identity body) name a) -> do
+ (size, body') <- advanceObjTypeBody body offset
+ doReturn (TypeSubStructure (Identity body') name a) size
)
- IntMap.empty
- constants
- let missing =
- filter (not . (`IntMap.member` imap)) [0 .. 2 ^ declaredSize - 1]
- unless (null missing) $
- tell
- [ Diagnostic
- Warning
- ( printf
- "Missing enum constants %s. Small enums should be fully \
- \ populated. Use 'reserved' if needed."
- (intercalate ", " (map show missing))
- )
- (unCommented ann)
- ]
-
- return declaredSize
-
-diagnosticError :: String -> Annot -> Compile a ()
-diagnosticError str a = tell [Diagnostic Error str (unCommented a)]
-
-insertIntoUnitInterface ::
- NonEmpty.NonEmpty String ->
- UnitInterface ->
- Commented SourceSpan ->
- ExportedValue ->
- UnitInterface
-insertIntoUnitInterface path ui (Commented comments srcspan) val =
- let docComments =
- mconcat
- ( mapMaybe
- ( \com -> do
- (DocComment txt) <- Just com
- return txt
- )
- comments
+ (([], startOffset) :: ([(Word32, Directed ObjTypeDecl S' F A)], Word32))
+ decls
+
+ advanceAndGetSize e = (,) <$> advanceStage () e <*> expressionToIntM e
+
+pattern RegisterBodyPattern :: BodyType F A -> [Directed RegisterBitsDecl s F A] -> A -> A -> RegisterBody s F A
+pattern RegisterBodyPattern u decls a b = RegisterBody u (Identity (DeferredRegisterBody decls b)) a
+
+-- registerBodyPattern u decls a b = RegisterBody u (Identity (DeferredRegisterBody decls a)) a
+
+advanceRegisterBody :: RegisterBody S F A -> M (Word32, RegisterBody S' F A)
+-- Handle the case where it's a union.
+advanceRegisterBody
+ (RegisterBodyPattern us (NonEmpty.nonEmpty -> Just decls) a b) = do
+ decls' <-
+ mapM
+ ( \d -> do
+ (sz, t) <- advanceDecl (undirected d)
+ return (sz, mapDirected (const t) d)
+ )
+ decls
+ calcSize <- case us of
+ Union {} -> do
+ checkJagged (toList decls')
+ return $ maximum (map fst (toList decls'))
+ Struct {} -> do
+ return $ sum (map fst (toList decls'))
+
+ return (calcSize, RegisterBodyPattern us (map snd $ toList decls') a b)
+
+-- Handle the case where there's no decls.
+advanceRegisterBody (RegisterBodyPattern u _ a b) =
+ return (0, RegisterBodyPattern u [] a b)
+advanceRegisterBody RegisterBody {} = error "GHC not smart enuf"
+
+checkJagged :: (Annotated t) => [(Word32, t f A)] -> Compile s ()
+checkJagged decls = do
+ let expectedSize = maximum (fmap fst decls)
+ forM_ decls $ \(sz, annot -> a) ->
+ when (sz /= expectedSize) $
+ emitDiagnosticWarning
+ ( printf
+ "[JaggedUnion] - All elements of a union should be the same size. \
+ \ this element is size %d, expected size %d. Maybe bundle this with \
+ \ reserved(%d)?"
+ sz
+ expectedSize
+ (expectedSize - sz)
+ )
+ a
+
+advanceDecl :: RegisterBitsDecl S F A -> M (Word32, RegisterBitsDecl S' F A)
+advanceDecl = \case
+ ReservedBits expr an -> do
+ sz <- expressionToIntM expr
+ (sz,)
+ <$> ( ReservedBits
+ <$> advanceStage () expr
+ <*> pure an
)
- in ui
- { rootScope =
- insertScope
- path
- ( Metadata srcspan docComments [],
- val
- )
- (rootScope ui)
- }
-
-insertTypeSize ::
- Annot ->
- LocalState ->
- Identifier f Annot ->
- SizeBits ->
- Compile GlobalState ()
-insertTypeSize annot (LocalState scopePath) (Identifier s idannot) size = do
- modifyM $
- \state@GlobalState
- { globalScope = globalScope,
- unitInterface = unitInterface
- } ->
- let fullName =
- NonEmpty.prependList
- (currentScope scopePath)
- (NonEmpty.singleton (Text.unpack s))
- in case upsertScope fullName (Left size) globalScope of
- (Just _, _) -> do
- diagnosticError (printf "Duplicate type %s" s) idannot
-
- compilationFailure
- (Nothing, n) ->
- let unitInterface' =
- insertIntoUnitInterface
- fullName
- unitInterface
- annot
- (ExportedBitsType size)
- in return $
- state
- { globalScope = n,
- unitInterface = unitInterface'
- }
- where
- modifyM fn = do
- s <- get
- put =<< fn s
+ DefinedBits mod ident typ annot -> do
+ size <- bitsTypeSize typ
+ (size,)
+ <$> (DefinedBits mod ident <$> advanceStage () typ <*> pure annot)
+ BitsSubStructure subBody subName ann -> do
+ (sz, body') <- advanceRegisterBody subBody
+ return (sz, BitsSubStructure body' subName ann)
+
+bitsTypeSize :: RegisterBitsTypeRef S F A -> M Word32
+bitsTypeSize (RegisterBitsArray tr nExpr _) = do
+ sz <- bitsTypeSize tr
+ n <- expressionToIntM nExpr
+ return (sz * n)
+bitsTypeSize
+ RegisterBitsReference
+ { bitsRefQualificationMetadata =
+ Identity (ExportedBitsDecl {exportedBitsDeclSizeBits = sz})
+ } = return sz
+bitsTypeSize (RegisterBitsJustBits expr _) =
+ expressionToIntM expr
+
+checkSizeMismatch :: A -> Word32 -> Word32 -> Compile s ()
+checkSizeMismatch _ a b | a == b = return ()
+checkSizeMismatch pos declaredSize calculatedSize =
+ emitDiagnosticError
+ ( printf
+ "Size assertion failed. Declared size %d, calculated %d"
+ declaredSize
+ calculatedSize
+ )
+ pos
+
+checkPositionAssertion :: A -> Word32 -> Word32 -> Compile s ()
+checkPositionAssertion _ a b | a == b = return ()
+checkPositionAssertion pos declaredPosition calculatedPostion =
+ emitDiagnosticError
+ ( printf
+ "Position assertion failed. Asserted 0x%x, calculated 0x%x"
+ declaredPosition
+ calculatedPostion
+ )
+ pos
+
+expressionToIntM ::
+ (Integral i, Integral (NumberType stage)) =>
+ Expression stage f A ->
+ Compile s i
+expressionToIntM expr =
+ resolveOrFail $
+ either
+ ( \reason -> Left [Diagnostic Error reason (unCommented $ annot expr)]
+ )
+ return
+ (expressionToInt expr)
+
+checkBitsSizeMod8 :: A -> Word32 -> M Word32
+checkBitsSizeMod8 _ w | w `mod` 8 == 0 = return (w `div` 8)
+checkBitsSizeMod8 a w = do
+ emitDiagnosticWarning
+ (printf "Register size %d is not a multiple of 8. Please add padding to this register." w)
+ a
+ return ((w `div` 8) + 1)
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 1c4df45..19b7323 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -120,8 +120,8 @@ instance AdvanceStage CurrentStage RegisterBitsTypeRef where
<$> advanceStage path typeref
<*> advanceStage path expr
<*> pure annot
- RegisterBitsReference () name annot ->
- return $ RegisterBitsReference () name annot
+ RegisterBitsReference q name annot ->
+ return $ RegisterBitsReference q name annot
RegisterBitsJustBits expr annot ->
RegisterBitsJustBits
<$> advanceStage path expr
@@ -130,16 +130,16 @@ instance AdvanceStage CurrentStage RegisterBitsTypeRef where
ident <-
internAnonymousBitsType path
=<< advanceStage path anonType
- return $ RegisterBitsReference () (identToName ident) annot
+ return $ RegisterBitsReference (pure ()) (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 () (identToName identifier) annot)
- (ReferencedObjType () name annot) ->
- return $ ReferencedObjType () name annot
+ return (ReferencedObjType (pure ()) (identToName identifier) annot)
+ (ReferencedObjType q name annot) ->
+ return $ ReferencedObjType q name annot
(ArrayObjType objType expr a) ->
ArrayObjType
<$> advanceStage path objType
@@ -197,13 +197,13 @@ reconfigureFiddleDecls p decls = do
where
resolveAnonymousObjType (Linkage linkage, objTypeBody) =
ObjTypeDecl
- ()
+ (pure ())
(Identifier linkage (annot objTypeBody))
(pure objTypeBody)
(annot objTypeBody)
resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) =
- BitsDecl () (Identifier linkage a) (EnumBitType expr body a) a
+ BitsDecl (pure ()) (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/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index 4d4bd32..b475801 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -124,9 +124,6 @@ deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Di
deriving instance AdvanceStage CurrentStage FiddleDecl
-diagnosticError :: String -> Annot -> Compile a ()
-diagnosticError str a = tell [Diagnostic Error str (unCommented a)]
-
instance AdvanceStage CurrentStage ImportStatement where
advanceStage s (ImportStatement path list _ a) = do
let what = Map.lookup path (importMap s)
@@ -134,7 +131,7 @@ instance AdvanceStage CurrentStage ImportStatement where
v <- case what of
Nothing -> do
- diagnosticError "Failed to lookup imports (This is a bug)" a
+ emitDiagnosticError "Failed to lookup imports (This is a bug)" a
return empty
Just (diags, val) -> do
tell diags
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index eddb3cb..7eea141 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -10,97 +10,333 @@
-- removed, as they become unnecessary once references are fully qualified.
module Language.Fiddle.Compiler.Qualification (qualificationPhase) where
-import Control.Monad.Identity
+import Control.Monad.RWS (MonadWriter (tell))
+import Control.Monad.State
import Data.Foldable (foldlM)
+import Data.List (intercalate)
+import Data.List.NonEmpty (NonEmpty (..), toList)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Maybe (mapMaybe)
import Data.Word
import Language.Fiddle.Ast
import Language.Fiddle.Compiler
import Language.Fiddle.Compiler.ConsistencyCheck ()
import Language.Fiddle.Internal.Scopes
-import Language.Fiddle.Internal.UnitInterface
+import Language.Fiddle.Internal.UnitInterface as UnitInterface
import Language.Fiddle.Types
+import Text.Printf (printf)
-type CurrentStage = Expanded
+type S = Expanded
-data GlobalState = GlobalState
- { _globalScope :: Scope String (Either SizeBits SizeBytes),
- _fileDependencies :: [FilePath],
- _unitInterface :: UnitInterface
+newtype GlobalState = GlobalState
+ { unitInterface :: UnitInterface
}
-newtype LocalState = LocalState (ScopePath String)
-
-type I = Identity
+data LocalState = LocalState
+ { currentScopePath :: ScopePath String,
+ ephemeralScope :: Scope String (Metadata, ExportedDecl)
+ }
-type Annot = Commented SourceSpan
+type F = Either [Diagnostic]
-type SizeBits = Word32
+type A = Commented SourceSpan
-type SizeBytes = Word32
+type M = Compile GlobalState
instance CompilationStage Expanded where
type StageAfter Expanded = Qualified
- type StageMonad Expanded = Compile GlobalState
+ type StageMonad Expanded = M
type StageState Expanded = LocalState
- type StageFunctor Expanded = I
- type StageAnnotation Expanded = Annot
+ type StageFunctor Expanded = F
+ type StageAnnotation Expanded = A
qualificationPhase :: CompilationPhase Expanded Qualified
qualificationPhase =
- pureCompilationPhase $
- fmap snd
- . subCompile (GlobalState mempty mempty mempty)
- . advanceStage (LocalState mempty)
+ pureCompilationPhase $ \t -> do
+ raw <-
+ fmap snd $
+ subCompile (GlobalState mempty) $
+ advanceStage
+ (LocalState mempty mempty)
+ (soakA t)
+
+ squeezeDiagnostics raw
-deriving instance AdvanceStage CurrentStage ObjTypeBody
+deriving instance AdvanceStage S ObjTypeBody
-deriving instance AdvanceStage CurrentStage DeferredRegisterBody
+deriving instance AdvanceStage S DeferredRegisterBody
-deriving instance AdvanceStage CurrentStage RegisterBody
+deriving instance AdvanceStage S RegisterBody
-deriving instance AdvanceStage CurrentStage AnonymousBitsType
+deriving instance AdvanceStage S AnonymousBitsType
-deriving instance AdvanceStage CurrentStage ImportStatement
+deriving instance AdvanceStage S ImportStatement
-deriving instance AdvanceStage CurrentStage BitType
+deriving instance AdvanceStage S BitType
-deriving instance AdvanceStage CurrentStage EnumBody
+deriving instance AdvanceStage S EnumBody
-deriving instance AdvanceStage CurrentStage EnumConstantDecl
+deriving instance AdvanceStage S EnumConstantDecl
-deriving instance AdvanceStage CurrentStage RegisterBitsDecl
+deriving instance AdvanceStage S RegisterBitsDecl
-deriving instance AdvanceStage CurrentStage ObjTypeDecl
+deriving instance AdvanceStage S ObjTypeDecl
-deriving instance AdvanceStage CurrentStage Expression
+deriving instance AdvanceStage S Expression
-instance AdvanceStage CurrentStage RegisterBitsTypeRef where
- advanceStage = undefined
+instance AdvanceStage S RegisterBitsTypeRef where
+ advanceStage localState = \case
+ RegisterBitsArray a b c ->
+ RegisterBitsArray
+ <$> advanceStage localState a
+ <*> advanceStage localState b
+ <*> pure c
+ RegisterBitsJustBits a b ->
+ RegisterBitsJustBits
+ <$> advanceStage localState a
+ <*> pure b
+ RegisterBitsReference _ name a -> do
+ v <- fmap snd <$> resolveName name localState
+ return $ RegisterBitsReference v name a
-instance AdvanceStage CurrentStage ObjType where
- advanceStage = undefined
+instance AdvanceStage S ObjType where
+ advanceStage localState = \case
+ ArrayObjType a b c ->
+ ArrayObjType
+ <$> advanceStage localState a
+ <*> advanceStage localState b
+ <*> pure c
+ ReferencedObjType _ name a -> do
+ v <- fmap snd <$> resolveName name localState
+ return $ ReferencedObjType v name a
-deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t)
+deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t)
-instance AdvanceStage CurrentStage PackageBody where
+instance AdvanceStage S PackageBody where
advanceStage localState (PackageBody decls a) =
PackageBody <$> advanceFiddleDecls localState decls <*> pure a
-instance AdvanceStage CurrentStage FiddleUnit where
+instance AdvanceStage S FiddleUnit where
advanceStage localState (FiddleUnit () decls a) =
FiddleUnit () <$> advanceFiddleDecls localState decls <*> pure a
+modifyEphemeralScope ::
+ ( Scope String (Metadata, ExportedDecl) -> Scope String (Metadata, ExportedDecl)
+ ) ->
+ LocalState ->
+ LocalState
+modifyEphemeralScope fn ls@LocalState {ephemeralScope = es} =
+ ls {ephemeralScope = fn es}
+
+modifyCurrentScopePath ::
+ (ScopePath String -> ScopePath String) ->
+ LocalState ->
+ LocalState
+modifyCurrentScopePath fn ls@LocalState {currentScopePath = cs} =
+ ls {currentScopePath = fn cs}
+
+resolveIdent :: (ExportableDecl d, Functor f) => Identifier f A -> LocalState -> M (F ([String], d))
+resolveIdent i = resolveSymbol (annot i) [identToString i]
+
+resolveName :: (ExportableDecl d, Functor f) => Name f A -> LocalState -> M (F ([String], d))
+resolveName n = resolveSymbol (annot n) (toList $ nameToList n)
+
+resolveSymbol :: (ExportableDecl d) => A -> [String] -> LocalState -> M (F ([String], d))
+resolveSymbol a (p : ps) (LocalState {ephemeralScope = ephemeralScope, currentScopePath = currentPath}) = do
+ GlobalState {unitInterface = UnitInterface {rootScope = rootScope}} <- get
+
+ let matches =
+ concatMap
+ ( mapMaybe (\(p, (m, e)) -> (p,) . (m,) <$> fromExportedDecl e)
+ . lookupScopeWithPath currentPath (p :| ps)
+ )
+ [rootScope, ephemeralScope]
+
+ return $
+ case matches of
+ [(p, (_, e))] -> Right (toList p, e)
+ [] ->
+ Left
+ [ Diagnostic
+ Error
+ ( printf "Could not resolve symbol %s" (intercalate "." (p : ps))
+ )
+ (unCommented a)
+ ]
+ (_ : _ : _) -> do
+ Left
+ [ Diagnostic
+ Error
+ ( printf
+ "Ambiguous occurance of %s"
+ (intercalate "." (p : ps))
+ )
+ (unCommented a)
+ ]
+resolveSymbol a _ _ =
+ return $ Left [Diagnostic Error "Empty path provided (this is a bug)" (unCommented a)]
+
advanceFiddleDecls ::
LocalState ->
- [TreeType (Directed FiddleDecl) CurrentStage] ->
- (StageMonad CurrentStage)
- [TreeType (Directed FiddleDecl) Qualified]
-advanceFiddleDecls (LocalState scopePath) decls = fmap (reverse . fst) $ do
+ [Directed FiddleDecl S F A] ->
+ M [Directed FiddleDecl Qualified F A]
+advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
foldlM
- ( \(declsRet, scopePath') -> \case
- Directed {directedSubtree = UsingDecl {usingName = name}} ->
- return (declsRet, addUsingPath (nameToList name) scopePath')
- _ -> undefined
+ ( \(declsRet, localState' :: LocalState) unsqeezedd -> do
+ d <- case squeeze unsqeezedd of
+ Left diags -> tell diags >> compilationFailure
+ Right x -> return x
+ case unsqeezedd of
+ (Directed directives t dann) ->
+ let doReturn ::
+ FiddleDecl Qualified F A ->
+ M ([Directed FiddleDecl Qualified F A], LocalState)
+ doReturn v = return (Directed directives v dann : declsRet, localState')
+ doReturnWith s v = return (Directed directives v dann : declsRet, s)
+ qualify = qualifyPath (currentScopePath localState')
+ metadata = directiveToMetadata d
+ in case t of
+ UsingDecl {usingName = name} ->
+ return (declsRet, modifyCurrentScopePath (addUsingPath (nameToList name)) localState')
+ OptionDecl key value ann -> doReturn $ OptionDecl key value ann
+ ImportDecl st@(ImportStatement {importInterface = interface}) a ->
+ let localState'' = modifyEphemeralScope (<> rootScope interface) localState'
+ in doReturnWith localState''
+ =<< ImportDecl
+ <$> advanceStage localState'' st
+ <*> pure a
+ PackageDecl _ name body ann ->
+ let qualifiedName = qualify (nameToList name)
+ localState'' = modifyCurrentScopePath (pushScope (nameToList name)) localState'
+ decl = ExportedPackageDecl (metadata qualifiedName)
+ in do
+ insertDecl decl
+ doReturn
+ =<< PackageDecl
+ (pure decl)
+ name
+ <$> mapM (advanceStage localState'') body
+ <*> pure ann
+ LocationDecl _ ident expr ann ->
+ let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
+ in do
+ exprValue <- expressionToIntM expr
+ let decl =
+ ExportedLocationDecl
+ (metadata qualifiedName)
+ exprValue
+ insertDecl decl
+ doReturn
+ =<< LocationDecl
+ (pure decl)
+ ident
+ <$> advanceStage localState' expr
+ <*> pure ann
+ BitsDecl _ ident typ ann ->
+ let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
+ in do
+ sizeBits <- getBitTypeDeclaredSize typ
+ let decl =
+ ExportedBitsDecl
+ (metadata qualifiedName)
+ sizeBits
+ insertDecl decl
+ doReturn
+ =<< BitsDecl
+ (pure decl)
+ ident
+ <$> advanceStage localState' typ
+ <*> pure ann
+ ObjTypeDecl _ ident body ann ->
+ let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
+ in do
+ typeSize <- calculateTypeSize =<< resolveOrFail body
+ let decl =
+ ExportedTypeDecl
+ (metadata qualifiedName)
+ typeSize
+ insertDecl decl
+ doReturn
+ =<< ObjTypeDecl
+ (pure decl)
+ ident
+ <$> mapM (advanceStage localState') body
+ <*> pure ann
+ ObjectDecl _ ident loc typ ann ->
+ let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
+ in do
+ location <- resolveLocationExpression localState' loc
+ exportedType <- objTypeToExport localState' typ
+ let decl =
+ ExportedObjectDecl
+ (metadata qualifiedName)
+ location
+ exportedType
+ insertDecl decl
+ doReturn
+ =<< ObjectDecl
+ (pure decl)
+ ident
+ <$> advanceStage localState' loc
+ <*> advanceStage localState' typ
+ <*> pure ann
)
- ([], scopePath)
+ ([], localState)
decls
+
+insertDecl :: (ExportableDecl d) => d -> M ()
+insertDecl decl =
+ modify $ \(GlobalState ui) -> GlobalState (UnitInterface.insert decl ui)
+
+objTypeToExport :: LocalState -> ObjType Expanded F A -> M ReferencedObjectType
+objTypeToExport ls = \case
+ ArrayObjType {arraySize = size, arrayObjType = objType} ->
+ ArrayObjectType
+ <$> objTypeToExport ls objType
+ <*> expressionToIntM size
+ ReferencedObjType {refName = n} -> do
+ (full, _ :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls
+ return $ ReferencedObjectType (intercalate "." full)
+
+calculateTypeSize :: ObjTypeBody Expanded F A -> M Word32
+calculateTypeSize (ObjTypeBody bodyType decls _) =
+ ( case bodyType of
+ Union {} -> maximum
+ Struct {} -> sum
+ )
+ <$> mapM calculateDeclSize decls
+ where
+ calculateDeclSize :: Directed ObjTypeDecl Expanded F A -> M Word32
+ calculateDeclSize (undirected -> decl) =
+ case decl of
+ AssertPosStatement {} -> return 0
+ RegisterDecl {regSize = size} -> expressionToIntM size
+ ReservedDecl {reservedExpr = size} -> expressionToIntM size
+ TypeSubStructure {subStructureBody = b} -> calculateTypeSize =<< resolveOrFail b
+
+getBitTypeDeclaredSize :: BitType Expanded F A -> M Word32
+getBitTypeDeclaredSize = \case
+ (EnumBitType declaredSize _ _) -> expressionToIntM declaredSize
+ (RawBits declaredSize _) -> expressionToIntM declaredSize
+
+resolveLocationExpression ::
+ (Integral i, Integral (NumberType stage)) =>
+ LocalState ->
+ Expression stage F A ->
+ M i
+resolveLocationExpression ls (Var var _) = do
+ (_, ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls
+ return (fromIntegral v)
+resolveLocationExpression _ e = expressionToIntM e
+
+expressionToIntM ::
+ (Integral i, Integral (NumberType stage)) =>
+ Expression stage f A ->
+ M i
+expressionToIntM expr =
+ resolveOrFail $
+ either
+ ( \reason -> Left [Diagnostic Error reason (unCommented $ annot expr)]
+ )
+ return
+ (expressionToInt expr)
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index f0ac96a..165949a 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -10,6 +10,7 @@
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))
@@ -20,6 +21,7 @@ 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 =
@@ -28,9 +30,26 @@ type Context stage =
ToGenericSyntaxTreeValue (NumberType stage),
Show (ImportInterface stage),
Show (FiddleUnitInterface stage),
- Show (QualificationMetadata stage ())
+ Show (QualificationMetadata stage ()),
+ Show (QualificationMetadata stage ExportedPackageDecl),
+ Show (QualificationMetadata stage ExportedLocationDecl),
+ Show (QualificationMetadata stage ExportedBitsDecl),
+ Show (QualificationMetadata stage ExportedTypeDecl),
+ Show (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 ::
@@ -103,6 +122,9 @@ class ToGenericSyntaxTreeValue v where
forall f a. (Show v) => v -> Maybe (GenericSyntaxTree f a)
toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show
+instance ToGenericSyntaxTreeValue (f a) where
+ toGenericSyntaxTreeValue = const Nothing
+
instance ToGenericSyntaxTreeValue Data.Text.Text where
toGenericSyntaxTreeValue = Just . SyntaxTreeValue . Data.Text.unpack
@@ -140,6 +162,11 @@ instance
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
@@ -157,6 +184,7 @@ instance
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
diff --git a/src/Language/Fiddle/Internal/Scopes.hs b/src/Language/Fiddle/Internal/Scopes.hs
index 70cadee..c232328 100644
--- a/src/Language/Fiddle/Internal/Scopes.hs
+++ b/src/Language/Fiddle/Internal/Scopes.hs
@@ -2,20 +2,22 @@
module Language.Fiddle.Internal.Scopes where
+import Data.Foldable
import Data.Aeson
import Data.Aeson.Key
import Data.List (inits)
import Data.List.NonEmpty (NonEmpty (..), prependList)
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, maybeToList)
+import Control.Arrow (Arrow(first))
-- | 'Scope' represents a hierarchical structure for storing key-value pairs.
-- It can contain nested sub-scopes, which are stored in 'subScopes',
-- and the values for a specific scope are stored in 'scopeValues'.
data Scope k v = Scope
{ subScopes :: Map k (Scope k v), -- Nested sub-scopes
- scopeValues :: Map k v -- Values stored in the current scope
+ scopeValues :: Map k [v] -- Values stored in the current scope
}
deriving (Eq, Ord, Show, Read, Functor, Foldable)
@@ -29,24 +31,24 @@ data ScopePath k = ScopePath
deriving (Eq, Ord, Show, Read)
-- | Qualify a name with the current scope.
-qualifyPath :: ScopePath k -> k -> [k]
-qualifyPath ScopePath {currentScope = scope} k = scope ++ [k]
+qualifyPath :: ScopePath k -> NonEmpty k -> NonEmpty k
+qualifyPath ScopePath {currentScope = scope} = prependList scope
-- | Push a new scope onto the current scope.
-pushScope :: k -> ScopePath k -> ScopePath k
+pushScope :: NonEmpty k -> ScopePath k -> ScopePath k
pushScope v s@ScopePath {currentScope = scope} =
- s {currentScope = scope ++ [v]}
+ s {currentScope = scope ++ toList v}
-- | Adds a path to the "using" paths.
-addUsingPath :: [k] -> ScopePath k -> ScopePath k
+addUsingPath :: NonEmpty k -> ScopePath k -> ScopePath k
addUsingPath path s@ScopePath {usingPaths = paths} =
- s {usingPaths = path : paths}
+ s {usingPaths = toList path : paths}
-- | The 'Semigroup' instance for 'Scope' allows combining two scopes,
-- where sub-scopes and values are merged together.
instance (Ord k) => Semigroup (Scope k t) where
(Scope ss1 sv1) <> (Scope ss2 sv2) =
- Scope (Map.unionWith (<>) ss1 ss2) (Map.union sv1 sv2)
+ Scope (Map.unionWith (<>) ss1 ss2) (Map.unionWith (<>) sv1 sv2)
-- | The 'Monoid' instance for 'Scope' provides an empty scope with
-- no sub-scopes or values.
@@ -71,9 +73,10 @@ instance Monoid (ScopePath k) where
-- This function effectively performs an "insert-or-update" operation, allowing
-- you to upsert values into nested scopes while tracking any existing value
-- that was replaced.
-upsertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> (Maybe t, Scope k t)
+upsertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> ([t], Scope k t)
upsertScope (s :| []) v (Scope ss sv) =
- Scope ss <$> Map.insertLookupWithKey (\_ n _ -> n) s v sv
+ first (fromMaybe []) $
+ Scope ss <$> Map.insertLookupWithKey (const (<>)) s [v] sv
upsertScope (s :| (a : as)) v (Scope ss sv) =
let subscope = fromMaybe mempty (Map.lookup s ss)
(replaced, subscope') = upsertScope (a :| as) v subscope
@@ -82,15 +85,18 @@ upsertScope (s :| (a : as)) v (Scope ss sv) =
insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
insertScope p s = snd . upsertScope p s
+singleton :: (Ord k) => NonEmpty k -> t -> Scope k t
+singleton ks t = insertScope ks t mempty
+
-- insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
-- insertScope a b = snd . upsertScope a b
-- | 'lookupScope' performs a lookup of a value in the scope using a key path
-- ('NonEmpty k'). It traverses through sub-scopes as defined by the path.
-lookupScope :: (Ord k) => NonEmpty k -> Scope k t -> Maybe t
-lookupScope (s :| []) (Scope _ sv) = Map.lookup s sv
+lookupScope :: (Ord k) => NonEmpty k -> Scope k t -> [t]
+lookupScope (s :| []) (Scope _ sv) = fromMaybe [] $ Map.lookup s sv
lookupScope (s :| (a : as)) (Scope ss _) = do
- subscope <- Map.lookup s ss
+ subscope <- maybeToList $ Map.lookup s ss
lookupScope (a :| as) subscope
-- | 'lookupScopeWithPath' searches for a key in the scope by trying all possible
@@ -122,10 +128,16 @@ lookupScopeWithPath ::
[(NonEmpty k, t)]
lookupScopeWithPath (ScopePath current others) key scope =
let allPaths = reverse (inits current) ++ others
- in flip concatMap allPaths $ \prefix -> do
- case lookupScope (prependList prefix key) scope of
- Just s -> [(prependList prefix key, s)]
- Nothing -> []
+ in do
+ prefix <- allPaths
+ let qualifiedKey = prependList prefix key
+ value <- lookupScope qualifiedKey scope
+ return (qualifiedKey, value)
+
+-- flip concatMap allPaths $ \prefix -> do
+-- case lookupScope (prependList prefix key) scope of
+-- Just s -> [(prependList prefix key, s)]
+-- Nothing -> []
instance (ToJSONKey k, ToJSON v, Ord k) => ToJSON (Scope k v) where
toJSON scope =
diff --git a/src/Language/Fiddle/Internal/UnitInterface.hs b/src/Language/Fiddle/Internal/UnitInterface.hs
index aacb71d..c5cbc2c 100644
--- a/src/Language/Fiddle/Internal/UnitInterface.hs
+++ b/src/Language/Fiddle/Internal/UnitInterface.hs
@@ -1,14 +1,19 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Language.Fiddle.Internal.UnitInterface where
import Data.Aeson
+import Data.List.NonEmpty (NonEmpty)
import Data.Text
import Data.Word
import GHC.Generics
import Language.Fiddle.Internal.Scopes (Scope)
+import qualified Language.Fiddle.Internal.Scopes as Scopes
import Language.Fiddle.Types (SourceSpan)
+data InternalDirectiveExpression
+ = InternalDirectiveExpressionNumber String
+ | InternalDirectiveExpressionString String
+ deriving (Generic, ToJSON, FromJSON, Show, Eq, Ord)
+
-- | Represents a compiler directive that provides configuration for the compiler
-- or its various backends. Directives can adjust the behavior of the compiler
-- or influence the code generation in the backends.
@@ -21,7 +26,7 @@ data InternalDirective = InternalDirective
directiveKey :: String,
-- | The optional value associated with this directive. Some directives
-- may not require a value (e.g., flags), in which case this field is 'Nothing'.
- directiveValue :: Maybe String
+ directiveValue :: Maybe InternalDirectiveExpression
}
deriving (Generic, ToJSON, FromJSON, Show, Eq, Ord)
@@ -29,7 +34,9 @@ data InternalDirective = InternalDirective
-- location, doc comments and compiler directives associated with the exported
-- symbol.
data Metadata = Metadata
- { -- | Source location for the exported symbol.
+ { -- | Fully-qualified path the the element.
+ metadataFullyQualifiedPath :: NonEmpty String,
+ -- | Source location for the exported symbol.
metadataSourceSpan :: SourceSpan,
-- | Doc comment associated with the symbol.
metadataDocComment :: Text,
@@ -44,11 +51,23 @@ data Metadata = Metadata
-- direct dependencies.
data UnitInterface where
UnitInterface ::
- { rootScope :: Scope String (Metadata, ExportedValue),
+ { rootScope :: Scope String (Metadata, ExportedDecl),
dependencies :: [FilePath]
} ->
UnitInterface
- deriving (Eq, Ord, Show)
+ deriving (Generic, Eq, Ord, Show, FromJSON, ToJSON)
+
+insert :: (ExportableDecl d) => d -> UnitInterface -> UnitInterface
+insert decl (UnitInterface sc deps) =
+ let metadata = getMetadata decl
+ path = metadataFullyQualifiedPath metadata
+ in UnitInterface (Scopes.insertScope path (metadata, toExportedDecl decl) sc) deps
+
+singleton :: (ExportableDecl d) => d -> UnitInterface
+singleton decl =
+ let path = metadataFullyQualifiedPath (getMetadata decl)
+ metadata = getMetadata decl
+ in UnitInterface (Scopes.singleton path (metadata, toExportedDecl decl)) []
instance Semigroup UnitInterface where
(<>) (UnitInterface s d) (UnitInterface s1 d1) =
@@ -57,24 +76,128 @@ instance Semigroup UnitInterface where
instance Monoid UnitInterface where
mempty = UnitInterface mempty mempty
-data ExportedValue where
- ExportedBitsType ::
- {exportBitsTypeSize :: Word32} ->
- ExportedValue
- ExportedObjType ::
- {exportObjTypeSize :: Word32} ->
- ExportedValue
+-- | Represents an exported package declaration in the syntax tree.
+-- This is a higher-level abstraction with metadata detailing the package.
+data ExportedPackageDecl where
+ ExportedPackageDecl ::
+ { -- | Metadata associated with the package.
+ exportedPackageMetadata :: Metadata
+ } ->
+ ExportedPackageDecl
+ deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
+
+-- | Represents an exported location declaration in the syntax tree.
+-- Contains metadata and the actual integer value of the location.
+data ExportedLocationDecl where
+ ExportedLocationDecl ::
+ { -- | Metadata associated with the location.
+ exportedLocationMetadata :: Metadata,
+ -- | The value of the location as an integer.
+ exportedLocationValue :: Integer
+ } ->
+ ExportedLocationDecl
deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
-instance ToJSON UnitInterface where
- toJSON ui =
- object
- [ "rootScope" .= rootScope ui,
- "dependencies" .= dependencies ui
- ]
+-- | Represents an exported bits declaration in the syntax tree.
+-- Contains metadata and the size of the bits in a Word32 format.
+data ExportedBitsDecl where
+ ExportedBitsDecl ::
+ { -- | Metadata associated with the bits declaration.
+ exportedBitsDeclMetadata :: Metadata,
+ -- | The size of the bits in this declaration.
+ exportedBitsDeclSizeBits :: Word32
+ } ->
+ ExportedBitsDecl
+ deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
-instance FromJSON UnitInterface where
- parseJSON = withObject "UnitInterface" $ \v ->
- UnitInterface
- <$> v .: "rootScope"
- <*> v .: "dependencies"
+-- | Represents an exported type declaration in the syntax tree.
+-- Contains metadata and the size of the type in bytes.
+data ExportedTypeDecl where
+ ExportedTypeDecl ::
+ { -- | Metadata associated with the type declaration.
+ exportedTypeDeclMetadata :: Metadata,
+ -- | The size of the type in bytes.
+ exportedTypeDeclSizeBytes :: Word32
+ } ->
+ ExportedTypeDecl
+ deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
+
+data ReferencedObjectType where
+ ReferencedObjectType ::
+ {objectTypeReference :: String} -> ReferencedObjectType
+ ArrayObjectType ::
+ { arrayObjectTypeType :: ReferencedObjectType,
+ arryObjecttTypeNumber :: Word32
+ } ->
+ ReferencedObjectType
+ deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
+
+-- | Represents an exported object declaration in the syntax tree.
+-- This includes metadata, location, and the type of the object.
+data ExportedObjectDecl where
+ ExportedObjectDecl ::
+ { -- | Metadata associated with the object declaration.
+ exportedObjectDeclMetadata :: Metadata,
+ -- | The memory location of the object.
+ exportedObjectDeclLocation :: Integer,
+ -- | The type of the object as a string.
+ exportedObjectDeclType :: ReferencedObjectType
+ } ->
+ ExportedObjectDecl
+ deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
+
+-- | A typeclass for converting various exported declarations into the
+-- generalized 'ExportedDecl' type. This allows treating different exported
+-- declarations uniformly in the compilation process.
+class ExportableDecl a where
+ toExportedDecl :: a -> ExportedDecl
+ fromExportedDecl :: ExportedDecl -> Maybe a
+ getMetadata :: a -> Metadata
+
+-- Instances of 'ExportableDecl' to convert specific exported declaration types
+-- into the generalized 'ExportedDecl' type.
+instance ExportableDecl ExportedPackageDecl where
+ toExportedDecl = ExportedPackage
+ fromExportedDecl = \case
+ ExportedPackage x -> Just x
+ _ -> Nothing
+ getMetadata = exportedPackageMetadata
+
+instance ExportableDecl ExportedLocationDecl where
+ toExportedDecl = ExportedLocation
+ fromExportedDecl = \case
+ ExportedLocation x -> Just x
+ _ -> Nothing
+ getMetadata = exportedLocationMetadata
+
+instance ExportableDecl ExportedBitsDecl where
+ toExportedDecl = ExportedBits
+ fromExportedDecl = \case
+ ExportedBits x -> Just x
+ _ -> Nothing
+ getMetadata = exportedBitsDeclMetadata
+
+instance ExportableDecl ExportedTypeDecl where
+ toExportedDecl = ExportedType
+ fromExportedDecl = \case
+ ExportedType x -> Just x
+ _ -> Nothing
+ getMetadata = exportedTypeDeclMetadata
+
+instance ExportableDecl ExportedObjectDecl where
+ toExportedDecl = ExportedObject
+ fromExportedDecl = \case
+ ExportedObject x -> Just x
+ _ -> Nothing
+ getMetadata = exportedObjectDeclMetadata
+
+-- | A generalized representation of different exported declarations.
+-- This data type allows for a uniform way to handle various exportable
+-- syntax tree elements (e.g., packages, locations, bits, types, objects).
+data ExportedDecl where
+ ExportedPackage :: ExportedPackageDecl -> ExportedDecl
+ ExportedLocation :: ExportedLocationDecl -> ExportedDecl
+ ExportedBits :: ExportedBitsDecl -> ExportedDecl
+ ExportedType :: ExportedTypeDecl -> ExportedDecl
+ ExportedObject :: ExportedObjectDecl -> ExportedDecl
+ deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index 00cce27..a2368ed 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -137,15 +137,15 @@ fiddleDeclP = do
case t of
KWOption -> OptionDecl <$> nextTextP <*> nextTextP
KWPackage ->
- PackageDecl ()
+ PackageDecl (pure ())
<$> name
<*> defer body packageBodyP
KWUsing -> UsingDecl (Witness ()) <$> name
- KWLocation -> LocationDecl () <$> ident <*> (tok TokEq >> expressionP)
- KWBits -> BitsDecl () <$> ident <*> (tok TokColon >> bitTypeP)
+ KWLocation -> LocationDecl (pure ()) <$> ident <*> (tok TokEq >> expressionP)
+ KWBits -> BitsDecl (pure ()) <$> ident <*> (tok TokColon >> bitTypeP)
KWImport -> ImportDecl <$> importStatementP
KWType ->
- ObjTypeDecl ()
+ ObjTypeDecl (pure ())
<$> ident
<*> ( do
tok_ TokColon
@@ -153,7 +153,7 @@ fiddleDeclP = do
defer body (objTypeBodyP bt)
)
KWInstance ->
- ObjectDecl ()
+ ObjectDecl (pure ())
<$> ident
<*> (tok KWAt *> expressionP)
<*> (tok TokColon *> objTypeP)
@@ -179,7 +179,7 @@ objTypeP = do
baseObjP :: P (A -> ObjType Parsed F A)
baseObjP =
- (ReferencedObjType () <$> name)
+ (ReferencedObjType (pure ()) <$> name)
<|> ( do
t <- bodyTypeP
AnonymousObjType (Witness ()) <$> defer body (objTypeBodyP t)
@@ -279,7 +279,7 @@ registerBitsTypeRefP = do
withMeta $
(RegisterBitsJustBits <$> exprInParenP)
<|> (RegisterBitsAnonymousType (Witness ()) <$> anonymousBitsTypeP)
- <|> (RegisterBitsReference () <$> name)
+ <|> (RegisterBitsReference (pure ()) <$> name)
anonymousBitsTypeP :: Pa AnonymousBitsType
anonymousBitsTypeP = withMeta $ do
@@ -307,12 +307,14 @@ enumConstantDeclP =
<|> (EnumConstantDecl <$> ident <*> (tok TokEq >> expressionP))
expressionP :: Pa Expression
-expressionP = withMeta $
- token $ \case
- (TokLitNum num) -> Just (LitNum num)
- (TokIdent i) -> Just $
- \(Commented cs s) -> Var (Identifier i (Commented [] s)) (Commented cs s)
- _ -> Nothing
+expressionP =
+ withMeta $
+ token
+ ( \case
+ (TokLitNum num) -> Just (LitNum num)
+ _ -> Nothing
+ )
+ <|> (Var <$> name)
body :: P [Token SourceSpan]
body = do
diff --git a/src/Language/Fiddle/Types.hs b/src/Language/Fiddle/Types.hs
index 8b022cf..02e6fed 100644
--- a/src/Language/Fiddle/Types.hs
+++ b/src/Language/Fiddle/Types.hs
@@ -3,6 +3,7 @@
module Language.Fiddle.Types where
import Data.Aeson
+import Data.Maybe
import Data.Text (Text, pack, splitOn, unpack)
import Text.Parsec.Pos
@@ -18,6 +19,16 @@ data SourceSpan = SourceSpan
data Commented a = Commented {comments :: ![Comment], unCommented :: !a}
deriving (Show)
+docComments :: Commented a -> Text
+docComments =
+ mconcat
+ . mapMaybe
+ ( \case
+ (DocComment t) -> Just t
+ _ -> Nothing
+ )
+ . comments
+
-- Helper to create the compressed span string
formatSpan :: SourceSpan -> String
formatSpan (SourceSpan ss se) =
generated by cgit (git 2.34.1) at 2025-04-28 19:34:25 +0000