diff options
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage2.hs | 22 | ||||
| -rw-r--r-- | src/Language/Fiddle/Internal/Scopes.hs | 34 |
2 files changed, 36 insertions, 20 deletions
diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs index 7306b3f..adf5450 100644 --- a/src/Language/Fiddle/Compiler/Stage2.hs +++ b/src/Language/Fiddle/Compiler/Stage2.hs @@ -9,7 +9,7 @@ module Language.Fiddle.Compiler.Stage2 (toStage3) where import Control.Monad (forM, forM_, unless, when) import Control.Monad.Identity (Identity (Identity)) -import Control.Monad.RWS (MonadState (get), MonadWriter (tell), gets, modify') +import Control.Monad.RWS (MonadState (get, put), MonadWriter (tell), gets, modify') import Data.Foldable (Foldable (toList), foldlM) import Data.Functor.Identity import qualified Data.IntMap as IntMap @@ -492,13 +492,23 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do return declaredSize -insertTypeSize :: LocalState -> Identifier f a -> SizeBits -> Compile GlobalState () -insertTypeSize (LocalState scopePath) (Identifier s _) size = do - modify' $ +diagnosticError :: String -> Annot -> Compile a () +diagnosticError str a = tell [Diagnostic Error str (unCommented a)] + +insertTypeSize :: LocalState -> Identifier f Annot -> SizeBits -> Compile GlobalState () +insertTypeSize (LocalState scopePath) (Identifier s annot) size = do + modifyM $ \(GlobalState globalScope) -> let fullName = NonEmpty.prependList (currentScope scopePath) (NonEmpty.singleton (Text.unpack s)) - in GlobalState $ - insertScope fullName (Right size) globalScope + in case upsertScope fullName (Right size) globalScope of + (Just _, _) -> do + diagnosticError (printf "Duplicate type %s" s) annot + compilationFailure + (Nothing, n) -> return $ GlobalState n + where + modifyM fn = do + s <- get + put =<< fn s diff --git a/src/Language/Fiddle/Internal/Scopes.hs b/src/Language/Fiddle/Internal/Scopes.hs index 280945d..302eab2 100644 --- a/src/Language/Fiddle/Internal/Scopes.hs +++ b/src/Language/Fiddle/Internal/Scopes.hs @@ -43,20 +43,26 @@ instance Semigroup (ScopePath k) where instance Monoid (ScopePath k) where mempty = ScopePath mempty mempty --- | 'insertScope' inserts a value 'v' into the scope at the specified --- key path ('NonEmpty k'). If the key path does not exist, it is created. -insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t -insertScope (s :| []) v (Scope ss sv) = Scope ss (Map.insert s v sv) -insertScope (s :| (a : as)) v (Scope ss sv) = - Scope - ( Map.alter - ( \case - (fromMaybe mempty -> mp) -> Just (insertScope (a :| as) v mp) - ) - s - ss - ) - sv +-- | 'upsertScope' attempts to insert a value 'v' into the 'Scope' at the given +-- key path ('NonEmpty k'). If the key path already exists, the value at the +-- final key is replaced, and the original value is returned in the result. +-- If the key path does not exist, it is created. The function returns a tuple +-- containing the previous value (if any) and the updated scope. +-- +-- 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 (s :| []) v (Scope ss sv) = + Scope ss <$> Map.insertLookupWithKey (\_ n _ -> n) 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 + in (replaced, Scope (Map.insert s subscope' ss) sv) + +-- 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. |