Add ContExpression syntax tree.

This is for expressions which must be calculatable at compile time.

9 files changed, 72 insertions, 22 deletions

diff --git a/src/Language/Fiddle/Ast/Internal/MetaTypes.hs b/src/Language/Fiddle/Ast/Internal/MetaTypes.hs
index 296324c..2be212e 100644
--- a/src/Language/Fiddle/Ast/Internal/MetaTypes.hs
+++ b/src/Language/Fiddle/Ast/Internal/MetaTypes.hs
@@ -233,6 +233,10 @@ instance Functor (Variant b t) where
 instance Foldable (Variant b t) where
   foldMap f t = foldMap f (toEither t)
 
+instance Traversable (Variant b t) where
+  traverse _ (LeftV l) = pure (LeftV l)
+  traverse fn (RightV r) = RightV <$> fn r
+
 instance Bifunctor (Variant b) where
   bimap fl _ (LeftV l) = LeftV (fl l)
   bimap _ fr (RightV r) = RightV (fr r)
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 5a8aa6d..613dae4 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -30,6 +30,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     FiddleUnit (..),
     Identifier (..),
     Expression (..),
+    ConstExpression (..),
     ImportStatement (..),
     ImportList (..),
     FiddleDecl (..),
@@ -53,6 +54,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
     mapDirectedM,
     asDirected,
     undirected,
+    trueValue,
   )
 where
 
@@ -284,6 +286,20 @@ data Identifier f a = Identifier
   }
   deriving (Generic, Annotated, Alter, Typeable, Walk)
 
+-- | Const expressions are expressions which must be eventually calculated
+-- during compilation. This means all the data required to fully calculate the
+-- expression must exist at compile time.
+data ConstExpression u (s :: Stage) :: SynTree where
+  ConstExpression ::
+    { constExpression :: Variant (s .>= Qualified) (N u) (Expression u s f a),
+      constExpressionAnnot :: a
+    } ->
+    ConstExpression u s f a
+  deriving (Generic, Annotated, Alter, Typeable, Walk)
+
+trueValue :: (s .>= Qualified ~ True) => ConstExpression u s f a -> N u
+trueValue (ConstExpression {constExpression = (LeftV v)}) = v
+
 -- | Expressions used within Fiddle, including literals and variables.
 data Expression (u :: unit) (s :: Stage) :: SynTree where
   -- | A numeric literal, whose value is dependent on the compilation stage.
@@ -385,7 +401,7 @@ data FiddleDecl :: StagedSynTree where
       -- | The location identifier.
       locationIdent :: Identifier f a,
       -- | The associated expression.
-      locationExpr :: Expression Address stage f a,
+      locationExpr :: ConstExpression Address stage f a,
       -- | Annotation for the location declaration.
       locationAnnot :: a
     } ->
@@ -462,7 +478,7 @@ data ObjType stage f a where
     { -- | The type of the array elements.
       arrayObjType :: ObjType stage f a,
       -- | The size of the array.
-      arraySize :: Expression Unitless stage f a,
+      arraySize :: ConstExpression Unitless stage f a,
       -- | Annotation for the array type.
       arrayAnnot :: a
     } ->
@@ -632,7 +648,7 @@ data RegisterBitsTypeRef stage f a where
     { -- | Reference to the array type.
       bitsArrayTypeRef :: RegisterBitsTypeRef stage f a,
       -- | Size of the array.
-      bitsArraySize :: Expression Unitless stage f a,
+      bitsArraySize :: ConstExpression Unitless stage f a,
       -- | Annotation for the array.
       bitsArrayAnnot :: a
     } ->
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index dd79bac..df31c8c 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -26,8 +26,8 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler.Backend
-import qualified Language.Fiddle.Compiler.Backend.Internal.FragTree as FragTree
 import Language.Fiddle.Compiler.Backend.Internal.FormattedWriter
+import qualified Language.Fiddle.Compiler.Backend.Internal.FragTree as FragTree
 import Language.Fiddle.Compiler.Backend.Internal.Writer
 import Language.Fiddle.Internal.UnitInterface
 import Language.Fiddle.Internal.UnitNumbers
@@ -77,7 +77,7 @@ newtype CFileState = CFileState
 
 requireInclude :: String -> M ()
 requireInclude file = do
-  b <- (Set.member file) <$> gets includedFiles
+  b <- gets (Set.member file . includedFiles)
   unless b $ do
     checkout hF $
       text $
@@ -283,8 +283,8 @@ writeRegSet
             tell $ Text.pack $ printf "  o->%s[%d] = in[%d];\n" fieldName i i
           tell "}\n\n"
 
-pattern DefinedBitsP :: String -> NonEmpty String -> N Bits -> RegisterBitsDecl Checked f a
-pattern DefinedBitsP bitsName bitsFullPath offset <-
+pattern DefinedBitsP :: String -> NonEmpty String -> N Bits -> RegisterBitsTypeRef Checked f a -> RegisterBitsDecl Checked f a
+pattern DefinedBitsP bitsName bitsFullPath offset typeRef <-
   ( DefinedBits
       { qBitsMetadata =
           Present
@@ -295,17 +295,22 @@ pattern DefinedBitsP bitsName bitsFullPath offset <-
                       { offset = offset
                       },
                 bitsFullPath = (NonEmpty.last &&& id -> (bitsName, bitsFullPath))
-              }
+              },
+        definedBitsTypeRef = typeRef
       }
     )
 
+-- | Decomposes a type ref into a type name (String) and a list of dimensions
+-- (in the case of being an array)
+-- decomposeBitsTypeRef :: RegisterBitsTypeRef Checked I A -> (String, [N Unitless])
+-- decomposeBitsTypeRef (RegisterBitsJustBits )
 writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> M ()
 writeRegisterBody structName regmeta = walk_ registerWalk
   where
     registerWalk :: forall t. (Walk t, Typeable t) => t I A -> M ()
     registerWalk t = case () of
       ()
-        | (Just (DefinedBitsP bitsName fullPath offset)) <- castTS t ->
+        | (Just (DefinedBitsP bitsName fullPath offset typeRef)) <- castTS t ->
             text $
               Text.pack $
                 printf
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 3d95ea0..3e81153 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -78,6 +78,8 @@ deriving instance AdvanceStage S PackageBody
 
 deriving instance AdvanceStage S FiddleDecl
 
+deriving instance AdvanceStage S (ConstExpression u)
+
 instance AdvanceStage S FiddleUnit where
   advanceStage () fu@(FiddleUnit _ decls a) =
     FiddleUnit (Present $ getUnitInterface fu) <$> mapM (advanceStage ()) decls <*> pure a
@@ -256,8 +258,7 @@ advanceDecl offset = \case
 bitsTypeSize :: RegisterBitsTypeRef S F A -> M (N Bits)
 bitsTypeSize (RegisterBitsArray tr nExpr _) = do
   sz <- bitsTypeSize tr
-  n <- expressionToIntM nExpr
-  return (sz .*. n)
+  return (sz .*. trueValue nExpr)
 bitsTypeSize
   RegisterBitsReference
     { bitsRefQualificationMetadata =
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index d9bce1e..0443b8d 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -71,6 +71,8 @@ deriving instance AdvanceStage CurrentStage BitType
 
 deriving instance AdvanceStage CurrentStage EnumBody
 
+deriving instance AdvanceStage CurrentStage (ConstExpression u)
+
 deriving instance AdvanceStage CurrentStage EnumConstantDecl
 
 deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t)
diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index a27a1dc..2568025 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -111,6 +111,8 @@ deriving instance AdvanceStage CurrentStage AnonymousBitsType
 
 deriving instance AdvanceStage CurrentStage BitType
 
+deriving instance AdvanceStage CurrentStage (ConstExpression u)
+
 deriving instance AdvanceStage CurrentStage EnumBody
 
 deriving instance AdvanceStage CurrentStage EnumConstantDecl
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs
index 67d3f29..56f1122 100644
--- a/src/Language/Fiddle/Compiler/Qualification.hs
+++ b/src/Language/Fiddle/Compiler/Qualification.hs
@@ -94,6 +94,14 @@ instance
   where
   convertInStage _ _ _ _ = Present <$> uniqueString "reserved"
 
+instance AdvanceStage S (ConstExpression u) where
+  advanceStage ls (ConstExpression (RightV exp) a) =
+    case exp of
+      Var var _ -> do
+        (_, ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls
+        return $ ConstExpression (LeftV $ fromIntegral v) a
+      LitNum (RightV v) _ -> return $ ConstExpression (LeftV v) a
+
 deriving instance AdvanceStage S ObjTypeBody
 
 deriving instance AdvanceStage S DeferredRegisterBody
@@ -326,11 +334,11 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                   LocationDecl _ ident expr ann ->
                     let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
                      in do
-                          exprValue <- expressionToIntM expr
+                          expr' <- advanceStage localState' expr
                           let decl =
                                 ExportedLocationDecl
                                   (metadata qualifiedName)
-                                  exprValue
+                                  (trueValue expr')
                           insertDecl decl
                           doReturn
                             =<< LocationDecl
@@ -355,7 +363,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                               <*> pure ann
                   ObjTypeDecl _ ident body ann ->
                     let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
-                        localState'' = modifyCurrentScopePath (pushScope (NonEmpty.singleton $ identToString ident)) localState'
+                        localState'' =
+                          modifyCurrentScopePath
+                            (pushScope (NonEmpty.singleton $ identToString ident))
+                            localState'
                      in do
                           typeSize <- calculateTypeSize =<< resolveOrFail body
                           let decl =
@@ -373,7 +384,8 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                     let qualifiedName = qualify (NonEmpty.singleton (identToString ident))
                      in do
                           location <- resolveLocationExpression localState' loc
-                          exportedType <- objTypeToExport localState' typ
+                          typ' <- advanceStage localState' typ
+                          exportedType <- objTypeToExport localState' typ'
                           let decl =
                                 ExportedObjectDecl
                                   (metadata qualifiedName)
@@ -385,7 +397,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do
                               (qMd decl)
                               ident
                               <$> advanceStage localState' loc
-                              <*> advanceStage localState' typ
+                              <*> pure typ'
                               <*> pure ann
     )
     ([], localState)
@@ -395,16 +407,16 @@ insertDecl :: (ExportableDecl d) => d -> M ()
 insertDecl decl =
   modify $ \(GlobalState ui c) -> GlobalState (UnitInterface.insert decl ui) c
 
-objTypeToExport :: LocalState -> ObjType Expanded F A -> M ReferencedObjectType
+objTypeToExport :: LocalState -> ObjType Qualified F A -> M ReferencedObjectType
 objTypeToExport ls = \case
   ArrayObjType {arraySize = size, arrayObjType = objType} ->
     ArrayObjectType
       <$> objTypeToExport ls objType
-      <*> expressionToIntM size
+      <*> pure (trueValue size)
   ReferencedObjType {refName = n} -> do
     (full, _ :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls
     case full of
-      (f:fs) -> return $ ReferencedObjectType (f :| fs)
+      (f : fs) -> return $ ReferencedObjectType (f :| fs)
       _ -> compilationFailure
 
 calculateTypeSize :: ObjTypeBody Expanded F A -> M (N Bytes)
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 49727f7..9b3089b 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -25,6 +25,7 @@ import GHC.Generics
 import GHC.TypeLits (KnownSymbol, symbolVal)
 import Language.Fiddle.Ast
 import Language.Fiddle.Internal.UnitInterface
+import Language.Fiddle.Internal.UnitNumbers
 import Language.Fiddle.Types
 
 type Context stage =
@@ -271,4 +272,8 @@ deriving instance (Context stage) => (ToGenericSyntaxTree (EnumConstantDecl stag
 
 deriving instance (Context stage) => (ToGenericSyntaxTree (PackageBody stage))
 
+deriving instance (Context stage) => (ToGenericSyntaxTree (ConstExpression Unitless stage))
+
+deriving instance (Context stage) => (ToGenericSyntaxTree (ConstExpression Address stage))
+
 deriving instance (Context stage) => (ToGenericSyntaxTree (Expression u stage))
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index ebbd51b..dea2dd5 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -146,7 +146,7 @@ fiddleDeclP = do
           <$> name
           <*> defer body packageBodyP
       KWUsing -> UsingDecl Witness <$> name
-      KWLocation -> LocationDecl noQMd <$> ident <*> (tok TokEq >> expressionP)
+      KWLocation -> LocationDecl noQMd <$> ident <*> (tok TokEq >> constExpressionP)
       KWBits -> BitsDecl noQMd <$> ident <*> (tok TokColon >> bitTypeP)
       KWImport -> ImportDecl <$> importStatementP
       KWType ->
@@ -176,7 +176,7 @@ objTypeP = do
     recur =
       ( do
           withMeta $ do
-            expr <- tok TokLBracket *> expressionP <* tok TokRBracket
+            expr <- tok TokLBracket *> constExpressionP <* tok TokRBracket
             recur' <- recur
             return (\met base -> recur' (ArrayObjType base expr met))
       )
@@ -274,7 +274,7 @@ registerBitsTypeRefP = do
     recurP =
       ( do
           withMeta $ do
-            expr <- tok TokLBracket *> expressionP <* tok TokRBracket
+            expr <- tok TokLBracket *> constExpressionP <* tok TokRBracket
             recur' <- recurP
             return (\met base -> recur' (RegisterBitsArray base expr met))
       )
@@ -311,6 +311,9 @@ enumConstantDeclP =
     (tok KWReserved >> EnumConstantReserved <$> (tok TokEq >> expressionP))
       <|> (EnumConstantDecl <$> ident <*> (tok TokEq >> expressionP))
 
+constExpressionP :: Pa (ConstExpression u)
+constExpressionP = withMeta $ ConstExpression . RightV <$> expressionP
+
 expressionP :: Pa (Expression u)
 expressionP =
   withMeta $