Fleshed out stage2 and made some big changes.

Delegated behavior of Compile monad to monad transformers MaybeT and
RWS.

2 files changed, 188 insertions, 34 deletions

diff --git a/src/Language/Fiddle/Compiler/Stage0.hs b/src/Language/Fiddle/Compiler/Stage0.hs
index d00d7cb..77c396e 100644
--- a/src/Language/Fiddle/Compiler/Stage0.hs
+++ b/src/Language/Fiddle/Compiler/Stage0.hs
@@ -20,7 +20,7 @@ toStage0 filePath text =
   case Language.Fiddle.Parser.parseFiddleText filePath text of
     Left pe -> do
       tell [parseErrorToDiagnostic pe]
-      hoistMaybe Nothing
+      compilationFailure
     Right a -> return a
 
 -- Gets the AST ready for Stage1 processing .This will report primarily
diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs
index ace5235..7a048fa 100644
--- a/src/Language/Fiddle/Compiler/Stage1.hs
+++ b/src/Language/Fiddle/Compiler/Stage1.hs
@@ -5,24 +5,31 @@
 
 module Language.Fiddle.Compiler.Stage1 (toStage2) where
 
-import Control.Monad.Identity (Identity(..))
-import Control.Monad.State (get, gets, put)
+import Control.Monad.Identity (Identity (..))
+import Control.Monad.State (get, gets, modify, put)
+import qualified Data.Char as Char
 import Data.List (intercalate)
 import Data.Text (Text)
+import qualified Data.Text as Text
 import Data.Type.Bool
+import Debug.Trace
 import GHC.Generics
 import GHC.TypeLits
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler
+import Language.Fiddle.Types
+import Text.Printf (printf)
 
-newtype Linkage = Linkage Text
+newtype Linkage = Linkage Text deriving (Show)
 
 newtype Path = Path [PathExpression]
 
 newtype PathExpression = PathExpression String
 
+type Annot = Commented SourceSpan
+
 joinPath :: Path -> String
-joinPath (Path l) = intercalate "_" (map (\(PathExpression s) -> s) l)
+joinPath (Path l) = intercalate "#" $ reverse (map (\(PathExpression s) -> s) l)
 
 -- Shorthand for Identity
 type I = Identity
@@ -40,22 +47,53 @@ class EasyStage2 t where
 instance EasyStage2 Identifier where
   toS2 (Identifier t a) = Identifier t a
 
+instance EasyStage2 Modifier where
+  toS2 (ModifierKeyword keyword annot) = ModifierKeyword keyword annot
+
 type M a = Compile (Stage2CompilerState a)
 
+internObjType :: Path -> ObjTypeBody Stage2 I a -> M a (Identifier Stage2 I a)
+internObjType path body =
+  let str = Text.pack $ joinPath path
+   in do
+        modify $ \(Stage2CompilerState objTypeBodies a) ->
+          Stage2CompilerState ((Linkage str, body) : objTypeBodies) a
+        return (Identifier str (annot body))
+
+internAnonymousBitsType :: Path -> AnonymousBitsType Stage2 I a -> M a (Identifier Stage2 I a)
+internAnonymousBitsType path anonymousBitsType =
+  let str = Text.pack $ joinPath path
+   in do
+        modify $ \(Stage2CompilerState a anonymousBitsTypes) ->
+          Stage2CompilerState a ((Linkage str, anonymousBitsType) : anonymousBitsTypes)
+        return (Identifier str (annot anonymousBitsType))
+
+traceState :: M a ()
+traceState = do
+  (Stage2CompilerState anonymousObjTypes anonymousBitsTypes) <- get
+  traceM $ printf "objtypes': %s\n" (show $ map fst anonymousObjTypes)
+  traceM $ printf "bittypes': %s\n" (show $ map fst anonymousBitsTypes)
+
 -- The second stage is a simplified version of the AST without anonymous
 -- declarations.
-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]
+toStage2 :: FiddleUnit Stage1 I Annot -> Compile () (FiddleUnit Stage2 I Annot)
+toStage2 (FiddleUnit decls annot) = do
+  (s, a) <-
+    subCompile (Stage2CompilerState [] []) $
+      FiddleUnit <$> reconfigureFiddleDecls (Path []) decls <*> pure annot
+  return a
+
+reconfigureFiddleDecls :: Path -> [FiddleDecl Stage1 I Annot] -> M Annot [FiddleDecl Stage2 I Annot]
 reconfigureFiddleDecls p decls = do
-  (Stage2CompilerState anonymousObjTypes anonymousBitsTypes, decls) <- pushState $ do
-    put (Stage2CompilerState [] [])
-    gets (,) <*> mapM (fiddleDeclToStage2 p) decls
+  -- (Stage2CompilerState anonymousObjTypes anonymousBitsTypes, decls) <- pushState $ do
+  --   put (Stage2CompilerState [] [])
+  --   gets (,) <*> mapM (fiddleDeclToStage2 p) decls
+
+  lastState <- get
+  put (Stage2CompilerState [] [])
+  decls <- mapM (fiddleDeclToStage2 p) decls
+  (Stage2CompilerState anonymousObjTypes anonymousBitsTypes) <- get
+  put lastState
 
   return $
     map resolveAnonymousObjType anonymousObjTypes
@@ -68,26 +106,142 @@ reconfigureFiddleDecls p decls = do
     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 (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
-  (ObjectDecl i expr typ a) ->
-    ObjectDecl (toS2 i) <$> toStage2Expr expr <*> pure undefined <*> pure a
-  _ -> undefined
-
-packageBodyToStage2 :: Path -> PackageBody Stage1 I a -> M a (PackageBody Stage2 I a)
+pushId :: Identifier stage f a -> Path -> Path
+pushId (Identifier str _) (Path lst) =
+  Path (PathExpression (Text.unpack str) : lst)
+
+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 (toS2 i1) (toS2 i2) a
+    (PackageDecl i (Identity body) a) -> do
+      (PackageDecl (toS2 i) . Identity <$> packageBodyToStage2 (pushId i path) body) <*> pure a
+    (LocationDecl i expr a) -> LocationDecl (toS2 i) <$> toStage2Expr expr <*> pure a
+    (BitsDecl i typ a) -> BitsDecl (toS2 i) <$> bitsTypeToStage2 (pushId i path) typ <*> pure a
+    (ObjTypeDecl i body a) -> ObjTypeDecl (toS2 i) <$> mapM (objTypeBodyToStage2 (pushId i path)) body <*> pure a
+    (ObjectDecl i expr typ a) ->
+      ObjectDecl (toS2 i) <$> toStage2Expr expr <*> objectTypeToStage2 (pushId i path) typ <*> pure a
+
+bitsTypeToStage2 :: Path -> BitType Stage1 I Annot -> M Annot (BitType Stage2 I Annot)
+bitsTypeToStage2 path = \case
+  RawBits expr a -> RawBits <$> toStage2Expr expr <*> pure a
+  EnumBitType expr enumBody a ->
+    EnumBitType <$> toStage2Expr expr <*> mapM (enumBodyToStage2 path) enumBody <*> pure a
+
+enumBodyToStage2 :: Path -> EnumBody Stage1 I Annot -> M Annot (EnumBody Stage2 I Annot)
+enumBodyToStage2 path = \case
+  EnumBody constants a -> EnumBody <$> mapM (enumConstantToStage2 path) constants <*> pure a
+
+enumConstantToStage2 :: Path -> EnumConstantDecl Stage1 I Annot -> M Annot (EnumConstantDecl Stage2 I Annot)
+enumConstantToStage2 path = \case
+  EnumConstantDecl i e a -> EnumConstantDecl (toS2 i) <$> toStage2Expr e <*> pure a
+  EnumConstantReserved e a -> EnumConstantReserved <$> toStage2Expr e <*> pure a
+
+objTypeBodyToStage2 :: Path -> ObjTypeBody Stage1 I Annot -> M Annot (ObjTypeBody Stage2 I Annot)
+objTypeBodyToStage2 path (ObjTypeBody decls annot) = ObjTypeBody <$> mapM (objTypeDeclToStage2 path) decls <*> pure annot
+
+objTypeDeclToStage2 :: Path -> ObjTypeDecl Stage1 I Annot -> M Annot (ObjTypeDecl Stage2 I Annot)
+objTypeDeclToStage2 path = \case
+  (AssertPosStatement expr annot) -> AssertPosStatement <$> toStage2Expr expr <*> pure annot
+  (RegisterDecl maybeModifier maybeIdentifier expression maybeBody annot) ->
+    let path' = maybe path (`pushId` path) maybeIdentifier
+     in RegisterDecl
+          (fmap toS2 maybeModifier)
+          (fmap toS2 maybeIdentifier)
+          <$> toStage2Expr expression
+          <*> mapM (registerBodyToStage2 path') maybeBody
+          <*> pure annot
+
+registerBodyToStage2 :: Path -> RegisterBody Stage1 I Annot -> M Annot (RegisterBody Stage2 I Annot)
+registerBodyToStage2 path (RegisterBody (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) =
+  RegisterBody . Identity
+    <$> ( DeferredRegisterBody
+            <$> mapM (registerBitsDeclToStage2 path) registerBitsDecl
+            <*> pure a1
+        )
+    <*> pure a2
+
+registerBitsDeclToStage2 :: Path -> RegisterBitsDecl Stage1 I Annot -> M Annot (RegisterBitsDecl Stage2 I Annot)
+registerBitsDeclToStage2 path = \case
+  ReservedBits expr a -> ReservedBits <$> toStage2Expr expr <*> pure a
+  DefinedBits maybeModifier identifier registerBitsTyperef annot ->
+    let path' = pushId identifier path
+     in ( DefinedBits
+            (fmap toS2 maybeModifier)
+            (toS2 identifier)
+            <$> registerBitsTypeRefToStage2 path' registerBitsTyperef
+            <*> pure annot
+        )
+
+registerBitsTypeRefToStage2 :: Path -> RegisterBitsTypeRef Stage1 I Annot -> M Annot (RegisterBitsTypeRef Stage2 I Annot)
+registerBitsTypeRefToStage2 path = \case
+  RegisterBitsArray typeref expr annot ->
+    RegisterBitsArray
+      <$> registerBitsTypeRefToStage2 path typeref
+      <*> toStage2Expr expr
+      <*> pure annot
+  RegisterBitsReference ident annot -> return (RegisterBitsReference (toS2 ident) annot)
+  RegisterBitsJustBits expr annot -> RegisterBitsJustBits <$> toStage2Expr expr <*> pure annot
+  RegisterBitsAnonymousType anonType annot -> do
+    ident <- internAnonymousBitsType path =<< anonymousBitsTypeToStage2 path anonType
+    return $ RegisterBitsReference ident annot
+
+anonymousBitsTypeToStage2 :: Path -> AnonymousBitsType Stage1 I Annot -> M Annot (AnonymousBitsType Stage2 I Annot)
+anonymousBitsTypeToStage2 path = \case
+  AnonymousEnumBody expr (Identity body) annot ->
+    AnonymousEnumBody
+      <$> toStage2Expr expr
+      <*> (Identity <$> enumBodyToStage2 path body)
+      <*> pure annot
+
+objectTypeToStage2 :: Path -> ObjType Stage1 I Annot -> M Annot (ObjType Stage2 I Annot)
+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 (toS2 ident) annot
+  (ArrayObjType objType expr a) ->
+    ArrayObjType <$> objectTypeToStage2 path objType <*> toStage2Expr expr <*> pure a
+
+packageBodyToStage2 :: Path -> PackageBody Stage1 I Annot -> M Annot (PackageBody Stage2 I Annot)
 packageBodyToStage2 p (PackageBody decls a) =
   PackageBody <$> reconfigureFiddleDecls p decls <*> pure a
 
-toStage2Expr :: Expression Stage1 I a -> M a (Expression Stage2 I a)
+toStage2Expr :: Expression Stage1 I Annot -> M Annot (Expression Stage2 I Annot)
 toStage2Expr = \case
   (Var i a) -> return $ Var (toS2 i) a
-  (LitNum t a) -> RealNum <$> parseNum t <*> pure a
-
-parseNum :: Text -> M a Integer
-parseNum = undefined
+  (LitNum t a) -> LitNum <$> parseNum (unCommented a) t <*> pure a
+
+parseNum :: SourceSpan -> Text -> M a Integer
+parseNum span txt = fromMayberOrFail span "Unable to parse number" $
+  case Text.unpack (Text.take 2 txt) of
+    "0b" -> toNumWithRadix (Text.drop 2 txt) 2
+    "0x" -> toNumWithRadix (Text.drop 2 txt) 16
+    ('0' : _) -> toNumWithRadix (Text.tail txt) 8
+    _ -> toNumWithRadix txt 10
+  where
+    removeUnders :: Text -> Text
+    removeUnders = Text.replace (Text.pack "_") Text.empty
+
+    toNumWithRadix :: Text -> Int -> Maybe Integer
+    toNumWithRadix (removeUnders -> txt) (fromIntegral -> radix) =
+      Text.foldl
+        ( \mAcc x ->
+            mAcc >>= (\acc -> (acc * radix +) <$> digitToInt x radix)
+        )
+        (Just 0)
+        txt
+
+    digitToInt :: Char -> Integer -> Maybe Integer
+    digitToInt (Char.toLower -> ch) radix =
+      let a
+            | Char.isDigit ch = Just (Char.ord ch - Char.ord '0')
+            | ch >= 'a' && ch <= 'f' = Just $ (Char.ord ch - Char.ord 'a') + 10
+            | otherwise = Nothing
+       in a
+            >>= ( \a' ->
+                    if a' >= fromIntegral radix
+                      then Nothing
+                      else Just (fromIntegral a')
+                )