diff options
| author | Josh Rahm <joshuarahm@gmail.com> | 2023-01-20 00:43:51 -0700 |
|---|---|---|
| committer | Josh Rahm <joshuarahm@gmail.com> | 2023-01-20 00:43:51 -0700 |
| commit | d6fae8c7de4bc952ba88f0c86cad9e8141eaf3df (patch) | |
| tree | ad37ff8c9f5d872c76868ca99fb36f7d50a7b639 | |
| parent | 19e7ae516cbdc600beefa05506d0f30f435ba6a4 (diff) | |
| download | fiddle-d6fae8c7de4bc952ba88f0c86cad9e8141eaf3df.tar.gz fiddle-d6fae8c7de4bc952ba88f0c86cad9e8141eaf3df.tar.bz2 fiddle-d6fae8c7de4bc952ba88f0c86cad9e8141eaf3df.zip | |
Start implementing the Stage2 compiler.
| -rw-r--r-- | src/Language/Fiddle/Ast.hs | 2 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage1.hs | 60 |
2 files changed, 47 insertions, 15 deletions
diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs index 60b9e11..61a637e 100644 --- a/src/Language/Fiddle/Ast.hs +++ b/src/Language/Fiddle/Ast.hs @@ -218,7 +218,7 @@ instance Annotated (RegisterBitsTypeRef stage) where data AnonymousBitsType stage f a where -- enum(<expr>) { <body> } - AnonymousEnumBody :: Expression 'Stage1 f a -> f (EnumBody stage f a) -> a -> AnonymousBitsType stage f a + AnonymousEnumBody :: Expression stage f a -> f (EnumBody stage f a) -> a -> AnonymousBitsType stage f a deriving (Generic, Annotated, Alter) data BitType (stage :: Stage) (f :: * -> *) a where diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs index 92ef09f..ace5235 100644 --- a/src/Language/Fiddle/Compiler/Stage1.hs +++ b/src/Language/Fiddle/Compiler/Stage1.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE TypeOperators #-} @@ -8,13 +5,24 @@ module Language.Fiddle.Compiler.Stage1 (toStage2) where -import Control.Monad.Identity (Identity) +import Control.Monad.Identity (Identity(..)) +import Control.Monad.State (get, gets, put) +import Data.List (intercalate) import Data.Text (Text) +import Data.Type.Bool import GHC.Generics +import GHC.TypeLits import Language.Fiddle.Ast import Language.Fiddle.Compiler -newtype Linkage = Linkage String +newtype Linkage = Linkage Text + +newtype Path = Path [PathExpression] + +newtype PathExpression = PathExpression String + +joinPath :: Path -> String +joinPath (Path l) = intercalate "_" (map (\(PathExpression s) -> s) l) -- Shorthand for Identity type I = Identity @@ -22,9 +30,9 @@ type I = Identity data Stage2CompilerState a = Stage2CompilerState -- Anonymous object type bodies that need to be re-linked - [(Linkage, ObjTypeBody Stage2 I a)] + ![(Linkage, ObjTypeBody Stage2 I a)] -- Anonymous enum bodies that need to be re-linked - [(Linkage, EnumBody Stage2 I a)] + ![(Linkage, AnonymousBitsType Stage2 I a)] class EasyStage2 t where toS2 :: t s1 I a -> t s2 I a @@ -36,15 +44,35 @@ type M a = Compile (Stage2CompilerState a) -- The second stage is a simplified version of the AST without anonymous -- declarations. -toStage2 :: FiddleUnit Stage1 I a -> Compile () (FiddleUnit Stage2 I a) -toStage2 (FiddleUnit decls annot) = - subCompile (Stage2CompilerState [] []) $ - FiddleUnit <$> mapM fiddleDeclToStage2 decls <*> pure annot +toStage2 :: FiddleUnit Stage1 I a -> Compile () (FiddleUnit Stage2 I (Maybe a)) +toStage2 fa = toStage2' $ fmap Just fa + where + toStage2' (FiddleUnit decls annot) = + subCompile (Stage2CompilerState [] []) $ + FiddleUnit <$> mapM (fiddleDeclToStage2 (Path [])) decls <*> pure annot + +reconfigureFiddleDecls :: Path -> [FiddleDecl Stage1 I a] -> M a [FiddleDecl Stage2 I a] +reconfigureFiddleDecls p decls = do + (Stage2CompilerState anonymousObjTypes anonymousBitsTypes, decls) <- pushState $ do + put (Stage2CompilerState [] []) + gets (,) <*> mapM (fiddleDeclToStage2 p) decls -fiddleDeclToStage2 :: FiddleDecl Stage1 I a -> M a (FiddleDecl Stage2 I a) -fiddleDeclToStage2 = \case + return $ + map resolveAnonymousObjType anonymousObjTypes + ++ map resolveAnonymousBitsType anonymousBitsTypes + ++ decls + where + resolveAnonymousObjType (Linkage linkage, objTypeBody) = + ObjTypeDecl (Identifier linkage (annot objTypeBody)) (pure objTypeBody) (annot objTypeBody) + + resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) = + BitsDecl (Identifier linkage a) (EnumBitType expr body a) a + +fiddleDeclToStage2 :: Path -> FiddleDecl Stage1 I a -> M a (FiddleDecl Stage2 I a) +fiddleDeclToStage2 path = \case (OptionDecl i1 i2 a) -> return $ OptionDecl (toS2 i1) (toS2 i2) a - (PackageDecl i body a) -> return $ PackageDecl (toS2 i) undefined a + (PackageDecl i (Identity body) a) -> do + PackageDecl (toS2 i) <$> (Identity <$> packageBodyToStage2 path body) <*> pure a (LocationDecl i expr a) -> LocationDecl (toS2 i) <$> toStage2Expr expr <*> pure a (BitsDecl i typ a) -> return $ BitsDecl (toS2 i) undefined a (ObjTypeDecl i body a) -> return $ ObjTypeDecl (toS2 i) undefined a @@ -52,6 +80,10 @@ fiddleDeclToStage2 = \case ObjectDecl (toS2 i) <$> toStage2Expr expr <*> pure undefined <*> pure a _ -> undefined +packageBodyToStage2 :: Path -> PackageBody Stage1 I a -> M a (PackageBody Stage2 I a) +packageBodyToStage2 p (PackageBody decls a) = + PackageBody <$> reconfigureFiddleDecls p decls <*> pure a + toStage2Expr :: Expression Stage1 I a -> M a (Expression Stage2 I a) toStage2Expr = \case (Var i a) -> return $ Var (toS2 i) a |