summaryrefslogtreecommitdiff
path: root/src/Language/Fiddle/Compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Fiddle/Compiler')
-rw-r--r--src/Language/Fiddle/Compiler/Stage1.hs20
-rw-r--r--src/Language/Fiddle/Compiler/Stage2.hs143
2 files changed, 134 insertions, 29 deletions
diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs
index 2e3acbc..a17afa1 100644
--- a/src/Language/Fiddle/Compiler/Stage1.hs
+++ b/src/Language/Fiddle/Compiler/Stage1.hs
@@ -5,6 +5,7 @@
module Language.Fiddle.Compiler.Stage1 (toStage2) where
+import qualified Data.List.NonEmpty as NonEmpty
import Control.Monad.Identity (Identity (..))
import Control.Monad.State (get, gets, modify, put)
import qualified Data.Char as Char
@@ -94,13 +95,17 @@ reconfigureFiddleDecls p decls = do
pushId :: Identifier f a -> Path -> Path
pushId (Identifier str _) (Path lst) =
Path (PathExpression (Text.unpack str) : lst)
+pushName :: Name f a -> Path -> Path
+pushName (Name idents _) path =
+ foldl (flip pushId) path idents
fiddleDeclToStage2 :: Path -> FiddleDecl Stage1 I Annot -> M Annot (FiddleDecl Stage2 I Annot)
fiddleDeclToStage2 path decl = do
case decl of
(OptionDecl i1 i2 a) -> return $ OptionDecl i1 i2 a
- (PackageDecl i (Identity body) a) -> do
- (PackageDecl i . Identity <$> packageBodyToStage2 (pushId i path) body) <*> pure a
+ (PackageDecl n (Identity body) a) -> do
+ (PackageDecl n . Identity <$> packageBodyToStage2 (pushName n path) body) <*> pure a
+ (UsingDecl n a) -> return $ UsingDecl n a
(LocationDecl i expr a) -> LocationDecl i <$> toStage2Expr expr <*> pure a
(BitsDecl i typ a) -> BitsDecl i <$> bitsTypeToStage2 (pushId i path) typ <*> pure a
(ObjTypeDecl i body a) -> ObjTypeDecl i <$> mapM (objTypeBodyToStage2 (pushId i path)) body <*> pure a
@@ -178,11 +183,14 @@ registerBitsTypeRefToStage2 path = \case
<$> registerBitsTypeRefToStage2 path typeref
<*> toStage2Expr expr
<*> pure annot
- RegisterBitsReference ident annot -> return (RegisterBitsReference ident annot)
+ RegisterBitsReference name annot -> return (RegisterBitsReference name annot)
RegisterBitsJustBits expr annot -> RegisterBitsJustBits <$> toStage2Expr expr <*> pure annot
RegisterBitsAnonymousType anonType annot -> do
ident <- internAnonymousBitsType path =<< anonymousBitsTypeToStage2 path anonType
- return $ RegisterBitsReference ident annot
+ return $ RegisterBitsReference (identToName ident) annot
+
+identToName :: Identifier I a -> Name I a
+identToName ident = Name (NonEmpty.singleton ident) (annot ident)
anonymousBitsTypeToStage2 :: Path -> AnonymousBitsType Stage1 I Annot -> M Annot (AnonymousBitsType Stage2 I Annot)
anonymousBitsTypeToStage2 path = \case
@@ -197,8 +205,8 @@ objectTypeToStage2 path = \case
(AnonymousObjType (Identity body) annot) -> do
body' <- objTypeBodyToStage2 path body
identifier <- internObjType path body'
- return (ReferencedObjType identifier annot)
- (ReferencedObjType ident annot) -> return $ ReferencedObjType ident annot
+ return (ReferencedObjType (identToName identifier) annot)
+ (ReferencedObjType name annot) -> return $ ReferencedObjType name annot
(ArrayObjType objType expr a) ->
ArrayObjType <$> objectTypeToStage2 path objType <*> toStage2Expr expr <*> pure a
diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs
index 431fc76..57b0b55 100644
--- a/src/Language/Fiddle/Compiler/Stage2.hs
+++ b/src/Language/Fiddle/Compiler/Stage2.hs
@@ -7,15 +7,18 @@
-- statements and checks that they are consistent with the calculations.
module Language.Fiddle.Compiler.Stage2 where
-import Control.Monad (forM_, unless, when)
-import Control.Monad.RWS (MonadWriter (tell), gets, modify')
-import Data.Foldable (foldlM)
+import Control.Monad (forM, forM_, unless, when)
+import Control.Monad.RWS (MonadState (get), MonadWriter (tell), gets, modify')
+import Data.Foldable (foldlM, Foldable (toList))
import Data.Functor.Identity
import qualified Data.IntMap as IntMap
import Data.Kind (Type)
-import Data.List (intercalate)
+import Data.List (inits, intercalate)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Word
@@ -33,29 +36,101 @@ type SizeBits = Word32
type SizeBytes = Word32
+data Scope t
+ = Scope
+ { subScopes :: Map String (Scope t),
+ scopeValues :: Map String t
+ }
+
+instance Semigroup (Scope t) where
+ (Scope a1 b1) <> (Scope a2 b2) = Scope (a1 <> a2) (b1 <> b2)
+
+instance Monoid (Scope t) where
+ mempty = Scope mempty mempty
+
+data ScopePath = ScopePath
+ { currentScope :: [String],
+ usingPaths :: [[String]]
+ }
+
+instance Semigroup ScopePath where
+ (ScopePath a1 b1) <> (ScopePath a2 b2) = ScopePath (a1 <> a2) (b1 <> b2)
+
+instance Monoid ScopePath where
+ mempty = ScopePath mempty mempty
+
+emptyScope :: Scope t
+emptyScope = Scope mempty mempty
+
+insertScope :: NonEmpty String -> t -> Scope t -> Scope 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 emptyScope -> mp) -> Just (insertScope (a :| as) v mp)
+ )
+ s
+ ss
+ )
+ sv
+
+lookupScope :: NonEmpty String -> Scope t -> Maybe t
+lookupScope (s :| []) (Scope _ sv) = Map.lookup s sv
+lookupScope (s :| (a : as)) (Scope ss _) = do
+ subscope <- Map.lookup s ss
+ lookupScope (a :| as) subscope
+
+lookupScopeWithPath :: ScopePath -> NonEmpty String -> Scope t -> Maybe t
+lookupScopeWithPath (ScopePath current others) key scope =
+ let all = reverse (inits current) ++ others
+ e = forM all $ \prefix -> do
+ case lookupScope (NonEmpty.prependList prefix key) scope of
+ Just s -> Left s
+ Nothing -> Right ()
+ in case e of
+ Left v -> Just v
+ Right _ -> Nothing
+
data Stage3State = Stage3State
- { typeSizes :: Map String SizeBits,
- objectSizes :: Map String SizeBytes,
- cursorBytes :: Word32,
- cursorBits :: Word32
+ { inScope :: Scope (Either SizeBits SizeBytes),
+ scopePath :: ScopePath
}
-addTypeSize :: Identifier f a -> SizeBits -> Compile Stage3State ()
-addTypeSize (Identifier s _) size = do
+insertTypeSize :: Identifier f a -> SizeBits -> Compile Stage3State ()
+insertTypeSize (Identifier s _) size = do
modify' $
\stage3State ->
- stage3State {typeSizes = Map.insert (Text.unpack s) size (typeSizes stage3State)}
-
-lookupTypeSize :: Identifier I Annot -> Compile Stage3State SizeBits
-lookupTypeSize (Identifier s a) = do
- mSize <- gets $ Map.lookup (Text.unpack s) . typeSizes
+ let fullName =
+ NonEmpty.prependList
+ ((currentScope . scopePath) stage3State)
+ (NonEmpty.singleton (Text.unpack s))
+ in stage3State
+ { inScope =
+ insertScope fullName (Right size) (inScope stage3State)
+ }
+
+-- addTypeSize :: Identifier f a -> SizeBits -> Compile Stage3State ()
+-- addTypeSize (Identifier s _) size = do
+-- modify' $
+-- \stage3State ->
+-- stage3State {typeSizes = Map.insert (Text.unpack s) size (typeSizes stage3State)}
+
+lookupTypeSize :: Name I Annot -> Compile Stage3State SizeBits
+lookupTypeSize (Name idents a) = do
+ let path = fmap (\(Identifier s _) -> Text.unpack s) idents
+ scopePath <- gets scopePath
+ mSize <- gets $ lookupScopeWithPath scopePath path . inScope
case mSize of
- Just sz -> return sz
- Nothing -> do
+ Just (Right sz) -> return sz
+ _ -> do
tell
[ Diagnostic
Error
- (printf "%s is not declared" s)
+ ( printf
+ "Cannot resolve %s"
+ (intercalate "." $ NonEmpty.toList path)
+ )
(unCommented a)
]
compilationFailure
@@ -65,7 +140,7 @@ expressionToStage3 = \case
LitNum n a -> LitNum n a
Var i a -> Var i a
-emptyState = Stage3State mempty mempty 0 0
+emptyState = Stage3State mempty mempty
toStage3 :: FiddleUnit Stage2 I Annot -> Compile () (FiddleUnit Stage3 I Annot)
toStage3 (FiddleUnit decls a) =
@@ -126,14 +201,36 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
return declaredSize
+addCurrentScope :: [String] -> Compile Stage3State ()
+addCurrentScope s = do
+ modify' $ \st@(Stage3State {scopePath = (ScopePath current others)}) ->
+ st {scopePath = ScopePath (current ++ s) others}
+
fiddleDeclToStage3 :: FiddleDecl Stage2 I Annot -> Compile Stage3State (FiddleDecl Stage3 I Annot)
fiddleDeclToStage3 = \case
OptionDecl i1 i2 a -> return $ OptionDecl i1 i2 a
- PackageDecl id body a -> PackageDecl id <$> mapM packageBodyToStage3 body <*> pure a
+ PackageDecl n@(Name idents _) body a -> do
+ let strs = map (\(Identifier (Text.unpack -> s) _) -> s) (toList idents)
+ Stage3State {scopePath = savedScopePath} <- get
+ addCurrentScope strs
+ PackageDecl n
+ <$> mapM packageBodyToStage3 body
+ <*> pure a
+ <* modify' (\st -> st {scopePath = savedScopePath})
+ UsingDecl n@(Name idents _) a -> do
+ let strs = map (\(Identifier t _) -> Text.unpack t) (toList idents)
+ modify'
+ ( \st ->
+ let (ScopePath cur using) = scopePath st
+ in st
+ { scopePath = ScopePath cur (strs : using)
+ }
+ )
+ return $ UsingDecl n a
LocationDecl id expr a -> return $ LocationDecl id (expressionToStage3 expr) a
BitsDecl id typ a -> do
typeSize <- getTypeSize typ
- addTypeSize id typeSize
+ insertTypeSize id typeSize
BitsDecl id <$> bitTypeToStage3 typ <*> pure a
ObjTypeDecl ident body a ->
ObjTypeDecl ident <$> mapM (\bt -> fst <$> objTypeBodyToStage3 bt 0) body <*> pure a
@@ -250,8 +347,8 @@ registerBitsTypeRefToStage3 = \case
( RegisterBitsArray ref' (expressionToStage3 expr) a,
size * fromIntegral multiplier
)
- RegisterBitsReference ident a ->
- (RegisterBitsReference ident a,) <$> lookupTypeSize ident
+ RegisterBitsReference name a ->
+ (RegisterBitsReference name a,) <$> lookupTypeSize name
RegisterBitsJustBits expr a ->
(RegisterBitsJustBits (expressionToStage3 expr) a,)
. fromIntegral
generated by cgit (git 2.34.1) at 2025-07-06 18:34:39 +0000