From 0a0f200a79a9e78b97addda6bd8e879d8c1c5d3e Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sat, 19 Oct 2024 02:36:56 -0600 Subject: 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. --- src/Language/Fiddle/Compiler/Expansion.hs | 70 +++++++++++++++---------------- 1 file changed, 35 insertions(+), 35 deletions(-) (limited to 'src/Language/Fiddle/Compiler/Expansion.hs') 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 -- cgit