Parser is able to parse the goal file.

author: Josh Rahm <joshuarahm@gmail.com> 2023-01-08 22:44:44 -0700
committer: Josh Rahm <joshuarahm@gmail.com> 2023-01-08 22:47:50 -0700
commit: def481d234ce5e1671d9faaa539477de8cd14640 (patch)
tree: 76bcd95f030571c506a73ddb021eeed7a6f6aec1
parent: 0c45ef8884ec82d26c47e952132d54d4bb8a9238 (diff)
download: fiddle-def481d234ce5e1671d9faaa539477de8cd14640.tar.gz
fiddle-def481d234ce5e1671d9faaa539477de8cd14640.tar.bz2
fiddle-def481d234ce5e1671d9faaa539477de8cd14640.zip
8 files changed, 419 insertions, 109 deletions
diff --git a/goal.fiddle b/goal.fiddle
index 312c580..d37a2c7 100644
--- a/goal.fiddle
+++ b/goal.fiddle
@@ -134,8 +134,8 @@ package gpio {
     assert_pos(0x1c);
     reg(32) : {
       lock : enum(1) {
-        unlocked = 0
-        locked = 1;
+        unlocked = 0,
+        locked = 1,
       } [16];
 
       lockk : (1);
@@ -150,7 +150,7 @@ package gpio {
     assert_pos(0x20);
     reg(64) : {
       afn : (4)[16];
-    }
+    };
 
     /**
      * The bit reset register.
@@ -159,7 +159,7 @@ package gpio {
     reg(32) : {
       wo br_r : (16);
       reserved (16);
-    }
+    };
 
     /**
      * Analog switch control for the pin.
@@ -167,10 +167,10 @@ package gpio {
     reg(32) : {
       asc_r : (16);
       reserved (16);
-    }
-  }
+    };
+  };
 
   object gpio_a at gpio_a_base : gpio_t;
   object gpio_b at gpio_b_base : gpio_t;
   object gpio_c at gpio_c_base : gpio_t;
-}
+};
diff --git a/package.yaml b/package.yaml
index 7eb5de2..fe4e70b 100644
--- a/package.yaml
+++ b/package.yaml
@@ -29,3 +29,6 @@ dependencies:
   - parsec
   - text
   - mtl
+  - aeson
+  - vector
+  - bytestring
diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs
index 03cf527..7600006 100644
--- a/src/Language/Fiddle/Ast.hs
+++ b/src/Language/Fiddle/Ast.hs
@@ -88,7 +88,6 @@ data FiddleDecl (stage :: Stage) (f :: * -> *) a where
     ObjType stage f a ->
     a ->
     FiddleDecl stage f a
-
   deriving (Generic, Annotated, Alter)
 
 data ObjType stage f a where
@@ -116,7 +115,6 @@ instance Annotated (ObjType stage) where
     (ArrayObjType _ _ a) -> a
     (ReferencedObjType _ a) -> a
 
-
 data ObjTypeBody (stage :: Stage) (f :: * -> *) a where
   ObjTypeBody :: [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a
   deriving (Generic, Annotated, Alter)
@@ -132,14 +130,13 @@ data ObjTypeDecl stage f a where
     Maybe (RegisterBody stage f a) ->
     a ->
     ObjTypeDecl stage f a
-
   deriving (Generic, Annotated, Alter)
 
 data Modifier stage f a where
   ModifierKeyword :: ModifierKeyword -> a -> Modifier stage f a
   deriving (Generic, Annotated, Alter)
 
-data ModifierKeyword = Rw | Ro | Wo
+data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read)
 
 data DeferredRegisterBody stage f a where
   DeferredRegisterBody ::
@@ -162,9 +159,20 @@ data RegisterBitsDecl stage f a where
     RegisterBitsTypeRef stage f a ->
     a ->
     RegisterBitsDecl stage f a
-
   deriving (Generic, Annotated, Alter)
 
+data Test stage f a where
+  Test ::
+    Identifier stage f a ->
+    Identifier stage f a ->
+    Identifier stage f a ->
+    Identifier stage f a ->
+    Identifier stage f a ->
+    Identifier stage f a ->
+    a ->
+    Test stage f a
+  deriving (Generic)
+
 data RegisterBitsTypeRef stage f a where
   -- <type>[<expr>]
   RegisterBitsArray ::
@@ -182,6 +190,13 @@ data RegisterBitsTypeRef stage f a where
     a ->
     RegisterBitsTypeRef 'Stage1 f a
 
+  {- (<expr>)
+   -
+   - The expression is just bits ... i.e. an integer.
+   -}
+  RegisterBitsJustBits ::
+    Expression stage f a -> a -> RegisterBitsTypeRef stage f a
+
 instance Alter (RegisterBitsTypeRef stage) where
   alter ffn fn = \case
     (RegisterBitsArray ref exp a) ->
@@ -190,12 +205,15 @@ instance Alter (RegisterBitsTypeRef stage) where
       RegisterBitsReference <$> alter ffn fn i <*> fn a
     (RegisterBitsAnonymousType t a) ->
       RegisterBitsAnonymousType <$> alter ffn fn t <*> fn a
+    (RegisterBitsJustBits e a) ->
+      RegisterBitsJustBits <$> alter ffn fn e <*> fn a
 
 instance Annotated (RegisterBitsTypeRef stage) where
   annot = \case
     (RegisterBitsArray _ _ a) -> a
     (RegisterBitsReference _ a) -> a
     (RegisterBitsAnonymousType _ a) -> a
+    (RegisterBitsJustBits _ a) -> a
 
 data AnonymousBitsType stage f a where
   -- enum(<expr>) { <body> }
@@ -204,8 +222,11 @@ data AnonymousBitsType stage f a where
 
 data BitType (stage :: Stage) (f :: * -> *) a where
   -- enum(<expr>) { <body> }
-  EnumBitType :: 
-    Expression stage f a -> f (EnumBody stage f a) -> a -> BitType stage f a
+  EnumBitType ::
+    Expression stage f a ->
+    f (EnumBody stage f a) ->
+    a ->
+    BitType stage f a
   -- (<expr>)
   RawBits :: Expression stage f a -> a -> BitType stage f a
   deriving (Generic, Annotated, Alter)
@@ -244,7 +265,6 @@ proxyOf _ = Proxy
 
 class Annotated (t :: (* -> *) -> * -> *) where
   annot :: t f a -> a
-
   default annot :: (Generic (t f a), GAnnot a (Rep (t f a))) => t f a -> a
   annot t = gannot (from t)
 
@@ -289,6 +309,9 @@ class Alter (t :: (* -> *) -> * -> *) where
     m (t f2 a2)
   alter ffn fn t = to <$> galter (proxyOf t) ffn fn (from t)
 
+instance (Alter t, Traversable f) => Functor (t f) where
+  fmap f t = runIdentity (alter return (return . f) t)
+
 class GAlter t f1 f2 a1 a2 r1 r2 where
   galter ::
     forall proxy x m.
@@ -358,7 +381,6 @@ instance
   where
   galter proxy ffn fn (M1 a) = M1 <$> galter proxy ffn fn a
 
-
 {--}
-squeeze :: (Alter t, Traversable  f, Monad f) => t f a -> f (t Identity a)
+squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a)
 squeeze = alter (fmap Identity) return
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
new file mode 100644
index 0000000..21cfa68
--- /dev/null
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Language.Fiddle.GenericTree where
+
+import Control.Monad.Writer (execWriter, tell)
+import Data.Aeson (Value (..), foldable, object, toEncoding, toJSON)
+import Data.Aeson.Encoding (text)
+import Data.Aeson.Types as Aeson
+import qualified Data.Foldable
+import Data.Functor.Classes (Show1, liftShowsPrec)
+import Data.Proxy
+import qualified Data.Text
+import qualified Data.Vector
+import GHC.Generics
+import GHC.TypeLits (KnownSymbol, symbolVal)
+import Language.Fiddle.Ast
+import Text.Printf (printf)
+
+data GenericSyntaxTree f a where
+  {- GenericSyntaxtTree with a name and children. -}
+  SyntaxTreeObject ::
+    String ->
+    [GenericSyntaxTree f a] ->
+    a ->
+    GenericSyntaxTree f a
+  SyntaxTreeList :: [GenericSyntaxTree f a] -> GenericSyntaxTree f a
+  SyntaxTreeDeferred :: f (GenericSyntaxTree f a) -> GenericSyntaxTree f a
+  SyntaxTreeValue :: String -> GenericSyntaxTree f a
+
+instance (Foldable f, Show a) => ToJSON (GenericSyntaxTree f a) where
+  toJSON = \case
+    (SyntaxTreeObject typ membs a) ->
+      object ["_type" .= typ, "_members" .= membs, "_annot" .= show a]
+    (SyntaxTreeList l) ->
+      Array $ Data.Vector.fromList $ map toJSON l
+    (SyntaxTreeDeferred fdef) ->
+      toJSON (SyntaxTreeList $ Data.Foldable.toList fdef)
+    (SyntaxTreeValue s) -> String (Data.Text.pack s)
+
+  toEncoding = \case
+    (SyntaxTreeObject typ membs a) ->
+      pairs $ "_type" .= typ <> "_members" .= membs <> "_annot" .= show a
+    (SyntaxTreeList l) ->
+      foldable $ map toJSON l
+    (SyntaxTreeDeferred fdef) ->
+      toEncoding (SyntaxTreeList $ Data.Foldable.toList fdef)
+    (SyntaxTreeValue s) -> text (Data.Text.pack s)
+
+class ToGenericSyntaxTreeValue v where
+  toGenericSyntaxTreeValue :: forall f a. v -> GenericSyntaxTree f a
+  default toGenericSyntaxTreeValue ::
+    forall f a. (Show v) => v -> GenericSyntaxTree f a
+  toGenericSyntaxTreeValue = SyntaxTreeValue . show
+
+instance ToGenericSyntaxTreeValue Data.Text.Text where
+  toGenericSyntaxTreeValue = SyntaxTreeValue . Data.Text.unpack
+
+class ToGenericSyntaxTree (t :: (* -> *) -> * -> *) where
+  toGenericSyntaxTree :: (Traversable f) => t f a -> GenericSyntaxTree f a
+  default toGenericSyntaxTree ::
+    (Generic (t f a), (GToGenericSyntaxTree (Rep (t f a)) f a), (Traversable f)) =>
+    t f a ->
+    GenericSyntaxTree f a
+  toGenericSyntaxTree = gToGenericSyntaxTree . from
+
+class GToGenericSyntaxTree r f a where
+  gToGenericSyntaxTree :: r x -> GenericSyntaxTree f a
+
+class GToMemberList r f a where
+  gToMemberList :: Int -> r x -> [GenericSyntaxTree f a]
+
+instance (ToGenericSyntaxTreeValue v) => GToMemberList (Rec0 v) f a where
+  gToMemberList _ = (: []) . toGenericSyntaxTreeValue . unK1
+
+instance
+  (Traversable f, ToGenericSyntaxTree r) =>
+  GToGenericSyntaxTree (Rec0 (f (r f a))) f a
+  where
+  gToGenericSyntaxTree k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1)
+
+instance
+  (Traversable f, Traversable f1, ToGenericSyntaxTree r) =>
+  GToGenericSyntaxTree (Rec0 (f1 (r f a))) f a
+  where
+  gToGenericSyntaxTree k1 =
+    SyntaxTreeList (Data.Foldable.toList $ toGenericSyntaxTree <$> unK1 k1)
+
+instance
+  (GToMemberList r f a, GToMemberList l f a) =>
+  GToMemberList (l :*: r) f a
+  where
+  gToMemberList n (l :*: r) = l1 ++ gToMemberList (length l1) r
+    where
+      l1 = gToMemberList n l
+
+instance (ToGenericSyntaxTree t, Traversable f) => GToMemberList (Rec0 (t f a)) f a where
+  gToMemberList _ a = [toGenericSyntaxTree (unK1 a)]
+
+instance
+  (ToGenericSyntaxTree t, Traversable f, Foldable l) =>
+  GToMemberList (Rec0 (l (t f a))) f a
+  where
+  gToMemberList _ as = toGenericSyntaxTree <$> Data.Foldable.toList (unK1 as)
+
+instance GToMemberList (Rec0 a) f a where
+  gToMemberList _ _ = []
+
+instance GToMemberList r f a => GToMemberList (M1 i c r) f a where
+  gToMemberList n (M1 r) = gToMemberList n r
+
+instance (ToGenericSyntaxTree r, Traversable f) => GToGenericSyntaxTree (Rec0 (r f a)) f a where
+  gToGenericSyntaxTree k1 = toGenericSyntaxTree $ unK1 k1
+
+instance
+  (GToMemberList r f a, KnownSymbol name, GAnnot a r) =>
+  (GToGenericSyntaxTree (C1 ('MetaCons name _f _b) r)) f a
+  where
+  gToGenericSyntaxTree c =
+    SyntaxTreeObject (symbolVal (nameProxy c)) (gToMemberList 0 (unM1 c)) (gannot c)
+    where
+      nameProxy :: C1 ('MetaCons name _f _b) r x -> Proxy name
+      nameProxy _ = Proxy
+
+instance
+  (GToGenericSyntaxTree l f a, GToGenericSyntaxTree r f a) =>
+  (GToGenericSyntaxTree (l :+: r) f a)
+  where
+  gToGenericSyntaxTree (L1 l) = gToGenericSyntaxTree l
+  gToGenericSyntaxTree (R1 r) = gToGenericSyntaxTree r
+
+instance (GToGenericSyntaxTree r f a) => (GToGenericSyntaxTree (M1 i c r) f a) where
+  gToGenericSyntaxTree (M1 r) = gToGenericSyntaxTree r
+
+-- deriving instance (ToGenericSyntaxTree (Test stage))
+
+deriving instance (ToGenericSyntaxTree (Identifier stage))
+
+deriving instance (ToGenericSyntaxTree (FiddleUnit stage))
+
+deriving instance (ToGenericSyntaxTree (FiddleDecl stage))
+
+instance ToGenericSyntaxTree (ObjType stage) where
+  toGenericSyntaxTree = \case
+    (AnonymousObjType body annot) ->
+      SyntaxTreeDeferred $
+        fmap
+          ( \body' ->
+              SyntaxTreeObject
+                "AnonymousObjType"
+                [toGenericSyntaxTree body']
+                annot
+          )
+          body
+    (ArrayObjType arr expr annot) ->
+      SyntaxTreeObject
+        "ArrayObjType"
+        [toGenericSyntaxTree arr, toGenericSyntaxTree expr]
+        annot
+    (ReferencedObjType ident a) ->
+      SyntaxTreeObject "ReferencedObjType" [toGenericSyntaxTree ident] a
+
+deriving instance (ToGenericSyntaxTree (ObjTypeBody stage))
+
+deriving instance (ToGenericSyntaxTree (ObjTypeDecl stage))
+
+deriving instance (ToGenericSyntaxTreeValue ModifierKeyword)
+
+deriving instance (ToGenericSyntaxTree (Modifier stage))
+
+deriving instance (ToGenericSyntaxTree (DeferredRegisterBody stage))
+
+deriving instance (ToGenericSyntaxTree (RegisterBody stage))
+
+deriving instance (ToGenericSyntaxTree (RegisterBitsDecl stage))
+
+instance ToGenericSyntaxTree (RegisterBitsTypeRef stage) where
+  toGenericSyntaxTree = \case
+    (RegisterBitsArray ref exp a) ->
+      SyntaxTreeObject
+        "RegisterBitsArray"
+        [toGenericSyntaxTree ref, toGenericSyntaxTree exp]
+        a
+    (RegisterBitsReference i a) ->
+      SyntaxTreeObject "RegisterBitsReference" [toGenericSyntaxTree i] a
+    (RegisterBitsAnonymousType t a) ->
+      SyntaxTreeObject "RegisterBitsAnonymousType " [toGenericSyntaxTree t] a
+    (RegisterBitsJustBits t a) ->
+      SyntaxTreeObject "RegisterBitsJustBits " [toGenericSyntaxTree t] a
+
+deriving instance (ToGenericSyntaxTree (AnonymousBitsType stage))
+
+deriving instance (ToGenericSyntaxTree (BitType stage))
+
+deriving instance (ToGenericSyntaxTree (EnumBody stage))
+
+deriving instance (ToGenericSyntaxTree (EnumConstantDecl stage))
+
+deriving instance (ToGenericSyntaxTree (PackageBody stage))
+
+instance (ToGenericSyntaxTree (Expression stage)) where
+  toGenericSyntaxTree = \case
+    LitNum t a -> SyntaxTreeObject "LitNum" [SyntaxTreeValue (show t)] a
+    RealNum t a -> SyntaxTreeObject "RealNum" [SyntaxTreeValue (show t)] a
+    Var t a -> SyntaxTreeObject "LitNum" [toGenericSyntaxTree t] a
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index 59faeda..94fbbf9 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -7,15 +7,16 @@ module Language.Fiddle.Parser
   )
 where
 
-import Debug.Trace
 import Data.Functor.Identity
 import Data.Text (Text)
 import qualified Data.Text
+import Debug.Trace
 import Language.Fiddle.Ast
 import Language.Fiddle.Tokenizer
 import Language.Fiddle.Types
 import Text.Parsec hiding (token)
 import qualified Text.Parsec
+import Text.Printf
 
 type F = Either ParseError
 
@@ -23,49 +24,98 @@ type S = [Token SourceSpan]
 
 type P = ParsecT S () Identity
 
+type A = Commented SourceSpan
+
 type Pa (a :: Stage -> (* -> *) -> * -> *) = P (a 'Stage1 F (Commented SourceSpan))
 
+comment :: P Comment
+comment =
+  token $ \case
+    (TokComment c) -> Just (NormalComment c)
+    (TokDocComment c) -> Just (DocComment c)
+    _ -> Nothing
+
+isComment :: Token s -> Bool
+isComment (Token t _) =
+  case t of
+    (TokComment _) -> True
+    (TokDocComment _) -> True
+    _ -> False
+
+-- Removes trailing comments from a list of tokens. Comments that don't preceed
+-- an actual language token have minimal semantic value and are thus discarded.
+stripTrailingComments :: [Token s] -> [Token s]
+stripTrailingComments = reverse . dropWhile isComment . reverse
+
 fiddleUnit :: Pa FiddleUnit
 fiddleUnit = do
-  withMeta $
-    FiddleUnit <$> many1 (fiddleDecl <* tok TokSemi)
+  withMeta
+    ( FiddleUnit <$> many1 (fiddleDecl <* tok TokSemi)
+    )
+    <* many comment
 
 fiddleDecl :: Pa FiddleDecl
-fiddleDecl =
-  withMeta $
-    choice
-      [ tok KWOption >> OptionDecl <$> ident <*> ident,
-        tok KWPackage >> PackageDecl
-          <$> ident
-          <*> defer body packageBody,
-        tok KWLocation >> LocationDecl <$> ident <*> (tok TokEq >> expression),
-        tok KWBits >> BitsDecl <$> ident <*> (tok TokColon >> bitType),
-        tok KWObjtype
-          >> ObjTypeDecl <$> ident <*> (tok TokColon >> defer body objTypeBody),
-        tok KWObject
-          >> ObjectDecl
+fiddleDecl = do
+  withMeta $ do
+    t <- tokenType <$> anyToken
+    case t of
+      KWOption -> OptionDecl <$> ident <*> ident
+      KWPackage -> do
+        p <-
+          PackageDecl
             <$> ident
-            <*> (tok KWAt *> expression)
-            <*> (tok TokColon *> objType)
-      ]
+            <*> defer body packageBody
+        printNext
+        return p
+      KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expression)
+      KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitType)
+      KWObjtype ->
+        ObjTypeDecl <$> ident <*> (tok TokColon >> defer body objTypeBody)
+      KWObject ->
+        ObjectDecl
+          <$> ident
+          <*> (tok KWAt *> expression)
+          <*> (tok TokColon *> objType)
+      _ ->
+        fail $
+          printf "Unexpected token %s. Expected top-level declaration." (show t)
+
+-- choice
+--   [ tok KWOption >> OptionDecl <$> ident <*> ident,
+--     tok KWPackage >> PackageDecl
+--       <$> ident
+--       <*> defer body packageBody,
+--     tok KWLocation >> LocationDecl <$> ident <*> (tok TokEq >> expression),
+--     tok KWBits >> BitsDecl <$> ident <*> (tok TokColon >> bitType),
+--     tok KWObjtype
+--       >> ObjTypeDecl <$> ident <*> (tok TokColon >> defer body objTypeBody),
+--     tok KWObject
+--       >> ObjectDecl
+--         <$> ident
+--         <*> (tok KWAt *> expression)
+--         <*> (tok TokColon *> objType)
+--   ]
 
 objType :: Pa ObjType
-objType = recur objType'
+objType = do
+  base <- withMeta baseObj
+  recur' <- recur
+  return $ recur' base
   where
-    recur b = do
-      recur
-        ( try $
-            withMeta $ do
-              t <- b
-              e <- tok TokLBrace *> expression <* tok TokRBrace
-              return (ArrayObjType t e)
-        )
-        <|> b
+    recur :: P (ObjType Stage1 F A -> ObjType Stage1 F A)
+    recur =
+      ( do
+          withMeta $ do
+            expr <- tok TokLBracket *> expression <* tok TokRBracket
+            recur' <- recur
+            return (\met base -> recur' (ArrayObjType base expr met))
+      )
+        <|> return id
 
-    objType' =
-      withMeta $
-        (ReferencedObjType <$> ident)
-          <|> (AnonymousObjType <$> defer body objTypeBody)
+    baseObj :: P (A -> ObjType Stage1 F A)
+    baseObj =
+      (ReferencedObjType <$> ident)
+        <|> (AnonymousObjType <$> defer body objTypeBody)
 
 exprInParen :: Pa Expression
 exprInParen = tok TokLParen *> expression <* tok TokRParen
@@ -73,8 +123,7 @@ exprInParen = tok TokLParen *> expression <* tok TokRParen
 objTypeBody :: Pa ObjTypeBody
 objTypeBody =
   withMeta $
-    withinBody $
-      ObjTypeBody <$> many (objTypeDecl <* tok TokSemi)
+    ObjTypeBody <$> many (objTypeDecl <* tok TokSemi)
 
 objTypeDecl :: Pa ObjTypeDecl
 objTypeDecl =
@@ -84,10 +133,10 @@ objTypeDecl =
         AssertPosStatement <$> exprInParen
     )
       <|> ( do
+              mod <- optionMaybe modifier
               tok KWReg
-              RegisterDecl
-                <$> optionMaybe modifier
-                <*> optionMaybe ident
+              RegisterDecl mod
+                <$> optionMaybe ident
                 <*> exprInParen
                 <*> optionMaybe (tok TokColon *> registerBody)
           )
@@ -108,8 +157,7 @@ registerBody = withMeta $ RegisterBody <$> defer body deferredRegisterBody
 deferredRegisterBody :: Pa DeferredRegisterBody
 deferredRegisterBody =
   withMeta $
-    withinBody $
-      DeferredRegisterBody <$> many (registerBitsDecl <* tok TokSemi)
+    DeferredRegisterBody <$> many (registerBitsDecl <* tok TokSemi)
 
 registerBitsDecl :: Pa RegisterBitsDecl
 registerBitsDecl =
@@ -119,25 +167,29 @@ registerBitsDecl =
     )
       <|> ( DefinedBits <$> optionMaybe modifier
               <*> ident
-              <*> registerBitsTypeRef
+              <*> (tok TokColon >> registerBitsTypeRef)
           )
 
 registerBitsTypeRef :: Pa RegisterBitsTypeRef
-registerBitsTypeRef = recur typeRef
+registerBitsTypeRef = do
+  base <- baseTypeRef
+  recur' <- recur
+  return (recur' base)
   where
-    recur b = do
-      recur
-        ( try $
-            withMeta $ do
-              t <- b
-              e <- tok TokLBrace *> expression <* tok TokRBrace
-              return (RegisterBitsArray t e)
-        )
-        <|> b
+    recur :: P (RegisterBitsTypeRef Stage1 F A -> RegisterBitsTypeRef Stage1 F A)
+    recur =
+      ( do
+          withMeta $ do
+            expr <- tok TokLBracket *> expression <* tok TokRBracket
+            recur' <- recur
+            return (\met base -> recur' (RegisterBitsArray base expr met))
+      )
+        <|> return id
 
-    typeRef =
+    baseTypeRef =
       withMeta $
-        (tok KWEnum >> RegisterBitsAnonymousType <$> anonymousBitsType)
+        (RegisterBitsJustBits <$> exprInParen)
+        <|> (RegisterBitsAnonymousType <$> anonymousBitsType)
           <|> (RegisterBitsReference <$> ident)
 
 anonymousBitsType :: Pa AnonymousBitsType
@@ -157,13 +209,12 @@ bitType = withMeta $ rawBits <|> enumType
 enumBody :: Pa EnumBody
 enumBody =
   withMeta $
-    withinBody $
-      EnumBody <$> many (enumConstantDecl <* tok TokComma)
+    EnumBody <$> many (enumConstantDecl <* tok TokComma)
 
 enumConstantDecl :: Pa EnumConstantDecl
 enumConstantDecl =
   withMeta $
-    (tok KWReserved >> EnumConstantReserved <$> exprInParen)
+    (tok KWReserved >> EnumConstantReserved <$> (tok TokEq >> expression))
       <|> (EnumConstantDecl <$> ident <*> (tok TokEq >> expression))
 
 expression :: Pa Expression
@@ -176,19 +227,23 @@ expression = withMeta $
 
 body :: P [Token SourceSpan]
 body = do
-  t0 <- tok TokLBrace
+  (_, b, _) <- body'
+  return b
+
+body' :: P (Token SourceSpan, [Token SourceSpan], Token SourceSpan)
+body' = do
+  l <- tokKeepComment TokLBrace
   ret <-
     concat
       <$> manyTill
-        ( body <|> fmap (: []) anyToken
+        ( ((\(b0, b1, b2) -> [b0] ++ b1 ++ [b2]) <$> body') <|> fmap (: []) anyToken
         )
-        (lookAhead $ tok TokRBrace)
-  t1 <- tok TokRBrace
-  return $ t0 : ret ++ [t1]
+        (lookAhead $ tokKeepComment TokRBrace)
+  r <- tokKeepComment TokRBrace
+
+  next <- lookAhead anyToken
 
--- Parses something within braces.
-withinBody :: P a -> P a
-withinBody p = tok TokLBrace *> p <* tok TokRBrace
+  return (l, stripTrailingComments ret, r)
 
 -- A deferred parsing takes a part of a text file (such as a body) and returns a
 -- deferred computation for parsing that section.
@@ -198,27 +253,32 @@ withinBody p = tok TokLBrace *> p <* tok TokRBrace
 -- can parse the stuff inside the body as it's own, separate parsing.
 defer :: P [Token SourceSpan] -> P b -> P (F b)
 defer p0 pb = do
-  contents <- p0
-
   sourcePos <- getPosition
 
-  traceM $ "Contents: " ++ show contents
-
-  return $
-    Text.Parsec.runParser
-      ( do
-          setPosition sourcePos
-          pb <* eof
-      )
-      ()
-      (sourceName sourcePos)
-      contents
+  Text.Parsec.runParser
+    ( do
+        setPosition sourcePos
+        pb <* eof
+    )
+    ()
+    (sourceName sourcePos)
+    <$> p0
 
 packageBody :: Pa PackageBody
 packageBody =
   withMeta $
-    withinBody $
-      PackageBody <$> many (fiddleDecl <* tok TokSemi)
+    PackageBody
+      <$> many
+        ( fiddleDecl
+            <* ( tok TokSemi <|> fail "Expected ';'"
+               )
+        )
+
+printNext :: P ()
+printNext = do
+  t <- lookAhead anyToken
+  traceM $ "NextToken: " ++ show t
+  return ()
 
 ident :: Pa Identifier
 ident =
@@ -230,19 +290,12 @@ ident =
 -- Takes a some parsable thing p and automatically parses the comments before
 -- and after and sets the positions and adds it to the annotation.
 withMeta :: P (Commented SourceSpan -> b) -> P b
-withMeta p = try $ do
+withMeta p = do
   comments <- many comment
   start <- getPosition
   fn <- p
   end <- getPosition
   return $ fn (Commented comments (SourceSpan start end))
-  where
-    comment :: P Comment
-    comment =
-      token $ \case
-        (TokComment c) -> Just (NormalComment c)
-        (TokDocComment c) -> Just (DocComment c)
-        _ -> Nothing
 
 token :: (T -> Maybe a) -> ParsecT S u Identity a
 token fn =
@@ -251,14 +304,27 @@ token fn =
     (\(Token _ (SourceSpan s1 _)) -> s1)
     (\(Token t _) -> fn t)
 
+tokKeepComment :: T -> P (Token SourceSpan)
+tokKeepComment t' = do
+  Text.Parsec.token
+    (\(Token t _) -> show t)
+    (\(Token _ (SourceSpan s1 _)) -> s1)
+    (\tok@(Token t _) -> if t == t' then Just tok else Nothing)
+
 tok :: T -> P (Token SourceSpan)
-tok t' =
+tok t' = do
+  many comment
   Text.Parsec.token
     (\(Token t _) -> show t)
     (\(Token _ (SourceSpan s1 _)) -> s1)
     (\tok@(Token t _) -> if t == t' then Just tok else Nothing)
 
 parseFiddleText :: String -> Text -> F (FiddleUnit 'Stage1 F (Commented SourceSpan))
-parseFiddleText sourceName txt = runIdentity .
-  Text.Parsec.runParserT
-    (fiddleUnit <* eof) () sourceName =<< tokenize sourceName txt
+parseFiddleText sourceName txt =
+  runIdentity
+    . Text.Parsec.runParserT
+      (fiddleUnit <* eof)
+      ()
+      sourceName
+    . stripTrailingComments
+    =<< tokenize sourceName txt
diff --git a/src/Language/Fiddle/Tokenizer.hs b/src/Language/Fiddle/Tokenizer.hs
index ec41042..4e06b92 100644
--- a/src/Language/Fiddle/Tokenizer.hs
+++ b/src/Language/Fiddle/Tokenizer.hs
@@ -108,3 +108,6 @@ parseToken = spaces *> tok parseToken' <* spaces
 
 tokenize :: String -> Text -> Either ParseError [Token SourceSpan]
 tokenize = Text.Parsec.runParser (many parseToken <* eof) ()
+
+tokenType :: Token SourceSpan -> T
+tokenType (Token t _) = t
diff --git a/src/Language/Fiddle/Types.hs b/src/Language/Fiddle/Types.hs
index 8d0c941..507b8cf 100644
--- a/src/Language/Fiddle/Types.hs
+++ b/src/Language/Fiddle/Types.hs
@@ -13,3 +13,4 @@ data SourceSpan = SourceSpan
   deriving (Eq, Ord, Show)
 
 data Commented a = Commented ![Comment] !a
+   deriving (Show)
diff --git a/src/Main.hs b/src/Main.hs
index d59181a..ea41afe 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -8,6 +8,9 @@ import qualified System.Environment as System
 import Control.Monad (forM_)
 import Control.Monad.Writer
 import qualified Language.Fiddle.Parser
+import Language.Fiddle.GenericTree (ToGenericSyntaxTree(toGenericSyntaxTree))
+import Data.Aeson (encode)
+import qualified Data.ByteString.Lazy.Char8 as BL
 
 main :: IO ()
 main = do
@@ -18,6 +21,7 @@ main = do
        text <- Data.Text.IO.readFile filePath
        case squeeze =<< Language.Fiddle.Parser.parseFiddleText filePath text of
          Left pe -> putStrLn $  "Parse Error: " ++ show pe
-         Right ast -> putStrLn "Parsing Okay"
+         Right ast -> do
+           putStrLn (BL.unpack $ encode $ toGenericSyntaxTree $ fmap (const ()) ast)
 
     _ -> putStrLn "Wrong Args"
author	Josh Rahm <joshuarahm@gmail.com>	2023-01-08 22:44:44 -0700
committer	Josh Rahm <joshuarahm@gmail.com>	2023-01-08 22:47:50 -0700
commit	def481d234ce5e1671d9faaa539477de8cd14640 (patch)
tree	76bcd95f030571c506a73ddb021eeed7a6f6aec1
parent	0c45ef8884ec82d26c47e952132d54d4bb8a9238 (diff)
download	fiddle-def481d234ce5e1671d9faaa539477de8cd14640.tar.gz fiddle-def481d234ce5e1671d9faaa539477de8cd14640.tar.bz2 fiddle-def481d234ce5e1671d9faaa539477de8cd14640.zip