Change the AST to use Names instead of Identifiers for ObjDecls and BitsDecls

This is to make anonymous expansion better and cleaner. It gets rid of
the hash-mark hack introduced earlier.

1 files changed, 35 insertions, 35 deletions

diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 0443b8d..5e7063e 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -10,6 +10,7 @@ import Control.Monad.Identity (Identity (..))
 import Control.Monad.State (get, modify, put)
 import qualified Data.Char as Char
 import Data.List (intercalate)
+import Data.List.NonEmpty (NonEmpty, (<|))
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Text (Text)
 import qualified Data.Text as Text
@@ -25,15 +26,10 @@ type Annot = Commented SourceSpan
 
 type CurrentStage = ImportsResolved
 
-newtype Path = Path [PathExpression]
-
-newtype PathExpression = PathExpression String
-
-joinPath :: Path -> String
-joinPath (Path l) = intercalate "#" $ reverse (map (\(PathExpression s) -> s) l)
+type Path = [Text]
 
 expandAst :: FiddleUnit CurrentStage I Annot -> Compile () (FiddleUnit Expanded I Annot)
-expandAst = fmap snd . subCompile (State [] []) . advanceStage (Path mempty)
+expandAst = fmap snd . subCompile (State [] []) . advanceStage mempty
 
 expansionPhase :: CompilationPhase CurrentStage Expanded
 expansionPhase = CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> expandAst)
@@ -41,7 +37,7 @@ expansionPhase = CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _
 -- Shorthand for Identity
 type I = Identity
 
-newtype Linkage = Linkage Text deriving (Show)
+newtype Linkage = Linkage (NonEmpty Text) deriving (Show)
 
 data State
   = State
@@ -100,9 +96,9 @@ instance AdvanceStage CurrentStage FiddleDecl where
   modifyState t =
     return
       . case t of
-        PackageDecl {packageName = n} -> pushName n
-        BitsDecl {bitsIdent = i} -> pushId i
-        ObjTypeDecl {objTypeIdent = i} -> pushId i
+        -- PackageDecl {packageName = n} -> pushName n
+        BitsDecl {bitsName = n} -> pushName n
+        ObjTypeDecl {objTypeIdent = i} -> pushName i
         ObjectDecl {objectIdent = i} -> pushId i
         _ -> id
 
@@ -130,17 +126,17 @@ instance AdvanceStage CurrentStage RegisterBitsTypeRef where
         <$> advanceStage path expr
         <*> pure annot
     RegisterBitsAnonymousType _ anonType annot -> do
-      ident <-
+      name <-
         internAnonymousBitsType path
           =<< advanceStage path anonType
-      return $ RegisterBitsReference (Identity Vacant) (identToName ident) annot
+      return $ RegisterBitsReference (Identity Vacant) name annot
 
 instance AdvanceStage CurrentStage ObjType where
   advanceStage path = \case
     (AnonymousObjType _ (Identity body) annot) -> do
       body' <- advanceStage path body
-      identifier <- internObjType path body'
-      return (ReferencedObjType (Identity Vacant) (identToName identifier) annot)
+      name <- internObjType path body'
+      return (ReferencedObjType (Identity Vacant) name annot)
     (ReferencedObjType q name annot) ->
       return $ ReferencedObjType q name annot
     (ArrayObjType objType expr a) ->
@@ -202,39 +198,43 @@ reconfigureFiddleDecls p decls = do
     resolveAnonymousObjType (Linkage linkage, objTypeBody) =
       ObjTypeDecl
         (Identity Vacant)
-        (Identifier linkage (annot objTypeBody))
+        (Name (fmap (\t -> Identifier t (annot objTypeBody)) (NonEmpty.reverse linkage)) (annot objTypeBody))
         (pure objTypeBody)
         (annot objTypeBody)
 
     resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) =
-      BitsDecl (Identity Vacant) (Identifier linkage a) (EnumBitType expr body a) a
+      BitsDecl
+        (Identity Vacant)
+        (Name (fmap (\t -> Identifier t a) (NonEmpty.reverse linkage)) a)
+        (EnumBitType expr body a)
+        a
 
 identToName :: Identifier I a -> Name I a
 identToName ident = Name (NonEmpty.singleton ident) (annot ident)
 
-internObjType :: Path -> ObjTypeBody Expanded I Annot -> M (Identifier I Annot)
-internObjType path body =
-  let str = Text.pack $ joinPath path
-   in do
-        modify $ \(State objTypeBodies a) ->
-          State ((Linkage str, body) : objTypeBodies) a
-        return (Identifier str (annot body))
+internObjType :: Path -> ObjTypeBody Expanded I Annot -> M (Name I Annot)
+internObjType [] _ = compilationFailure
+internObjType (NonEmpty.fromList -> path) body =
+  do
+    modify $ \(State objTypeBodies a) ->
+      State ((Linkage path, body) : objTypeBodies) a
+    let a = annot body
+     in return (Name (fmap (\t -> Identifier t a) (NonEmpty.reverse path)) a)
 
 internAnonymousBitsType ::
   Path ->
   AnonymousBitsType Expanded I Annot ->
-  M (Identifier I Annot)
-internAnonymousBitsType path anonymousBitsType =
-  let str = Text.pack $ joinPath path
-   in do
-        modify $ \(State a anonymousBitsTypes) ->
-          State a ((Linkage str, anonymousBitsType) : anonymousBitsTypes)
-        return (Identifier str (annot anonymousBitsType))
+  M (Name I Annot)
+internAnonymousBitsType [] _ = compilationFailure
+internAnonymousBitsType (NonEmpty.fromList -> path) anonymousBitsType =
+  do
+    modify $ \(State a anonymousBitsTypes) ->
+      State a ((Linkage path, anonymousBitsType) : anonymousBitsTypes)
+    let a = annot anonymousBitsType
+     in return (Name (fmap (\t -> Identifier t a) (NonEmpty.reverse path)) a)
 
 pushId :: Identifier f a -> Path -> Path
-pushId (Identifier str _) (Path lst) =
-  Path (PathExpression (Text.unpack str) : lst)
+pushId (Identifier str _) lst = str : lst
 
 pushName :: Name f a -> Path -> Path
-pushName (Name idents _) path =
-  foldl (flip pushId) path idents
+pushName (Name idents _) path = foldl (flip pushId) path idents