Add import statements, add using statements, properly cross-package

symbols.

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