summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--goal.fiddle29
-rw-r--r--src/Language/Fiddle/Ast.hs154
-rw-r--r--src/Language/Fiddle/Compiler/Stage1.hs15
-rw-r--r--src/Language/Fiddle/Compiler/Stage2.hs39
-rw-r--r--src/Language/Fiddle/GenericTree.hs23
-rw-r--r--src/Language/Fiddle/Parser.hs89
-rw-r--r--src/Language/Fiddle/Tokenizer.hs47
-rw-r--r--vim/syntax/fiddle.vim15
8 files changed, 349 insertions, 62 deletions
diff --git a/goal.fiddle b/goal.fiddle
index b59acb4..c35e172 100644
--- a/goal.fiddle
+++ b/goal.fiddle
@@ -1,24 +1,31 @@
+option board stm32l432;
option endian little;
+option processor arm_cortex_m4;
+option align 32;
-// package for the GPIO system.
+import "./types.fdl" (data_t);
+[[ search = ".local/fiddle/libs" ]]
+import "./stm32l432.fdl";
+
+[[ cpp: namespace = "stm32l432::gpio" ]]
+[[ rust: package = "Stm32l432.Gpio" ]]
+[[ zig: package = "stm32l432.gpio" ]]
+[[ c: prefix = "stm32l432_gpio_" ]]
package gpio {
location gpio_a_base = 0x4800_0000;
location gpio_b_base = 0x4800_0400;
location gpio_c_base = 0x4800_0800;
- /** IO Data. This is just an expressive boolean. */
bits data_t : enum(1) {
- low = 0,
- high = 1,
+ high = 0b1,
+ low = 0b0,
};
/**
* Structure of the GPIO port on an stm32l432
- */
- type gpio_t : struct {
- assert_pos(0);
+
reg (32) : struct {
/** The mode for each pin. */
mode_r : enum(2) {
@@ -45,7 +52,8 @@ package gpio {
* The output type.
*/
assert_pos(0x04);
- reg ocfg_reg(32) : struct {
+ [[ noexport ]]
+ reg ocfg_r(32) : struct {
otype_r : enum(1) {
/**
* The GPIO pin is capable of sinking to ground (for LOW) or providing
@@ -67,6 +75,8 @@ package gpio {
* Sets the speed of the provided GPIO pin.
*/
assert_pos(0x08);
+
+ [[ noexport ]]
reg (32) : struct {
ospeed_r : enum(2) {
low = 0,
@@ -80,6 +90,7 @@ package gpio {
* Pullup/Pulldown type
*/
assert_pos(0x0c);
+ [[ noexport ]]
wo reg (32) : struct {
union {
pupd_r : enum(2) {
@@ -112,6 +123,7 @@ package gpio {
assert_pos(0x10);
ro reg (32) : struct {
id_r : data_t[16];
+
reserved(16);
};
@@ -202,6 +214,7 @@ package gpio {
*/
reg(32) : struct {
asc_r : (16);
+
reserved (16);
};
};
diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs
index 8352975..bb6605e 100644
--- a/src/Language/Fiddle/Ast.hs
+++ b/src/Language/Fiddle/Ast.hs
@@ -18,13 +18,79 @@ import Data.Typeable
import GHC.Generics
import GHC.TypeLits
--- The type of a number at each stage in compilation. Numbers should be parsed
--- in Stage2.
-type family NumberType (a :: Stage) where
+-- The Kind types should have for SyntaxTrees.
+--
+-- A synatx tree kind should take as parameters, an applicative functor for the
+-- first argument. This applicative functor allows errors and warnings to be
+-- contained to their deferred regions during compilation, so more errors may be
+-- reported an once.
+--
+-- The second argument is the annotation type. Every syntax tree element has an
+-- annotation. When initially parsing, this annotation is a list of comments
+-- that came before the element and the source position of the element.
+type SynTreeKind = (Type -> Type) -> Type -> Type
+
+-- The Type of number during each stage of compilation. When in the first stage,
+-- numbers are just strings like anything else. In later stages, numbers get
+-- parsed into actual integers. This makes it easier to process later.
+type family NumberType (a :: Stage) :: Type where
NumberType Stage1 = Text
NumberType Stage2 = Integer
NumberType Stage3 = Integer
+-- The type that represents an import statement. In the early stages of
+-- compilation, this is just a string representing the import path, but in later
+-- stages of compilation, this actually gets replaced by an abstract
+-- representation of the imported material.
+type family ImportType (stage :: Stage) :: SynTreeKind where
+ ImportType Stage1 = ImportStatement
+ ImportType Stage2 = ImportStatement
+ ImportType Stage3 = ImportStatement
+
+-- [[packed, rust: name="field_name"]]
+data Directive f a where
+ Directive :: f (DirectiveBody f a) -> a -> Directive f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data DirectiveBody f a where
+ DirectiveBody :: [DirectiveElement f a] -> a -> DirectiveBody f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data DirectiveElement f a where
+ -- <key>
+ DirectiveElementKey ::
+ Maybe (Identifier f a) -> Identifier f a -> a -> DirectiveElement f a
+ -- (<backend>:)? <key>=<value>
+ DirectiveElementKeyValue ::
+ Maybe (Identifier f a) ->
+ Identifier f a ->
+ DirectiveExpression f a ->
+ a ->
+ DirectiveElement f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data DirectiveExpression f a where
+ DirectiveString :: Text -> a -> DirectiveExpression f a
+ DirectiveNumber :: Text -> a -> DirectiveExpression f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data Directed t f a where
+ Directed :: [Directive f a] -> t f a -> a -> Directed t f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+mapDirected :: (t f a -> t' f a) -> Directed t f a -> Directed t' f a
+mapDirected fn (Directed dr tfa a) = Directed dr (fn tfa) a
+
+mapDirectedM ::
+ (Monad m) => (t f a -> m (t' f a)) -> Directed t f a -> m (Directed t' f a)
+mapDirectedM fn (Directed dr tfa a) = Directed dr <$> fn tfa <*> pure a
+
+asDirected :: (Annotated t) => t f a -> Directed t f a
+asDirected tfa = Directed [] tfa (annot tfa)
+
+undirected :: Directed t f a -> t f a
+undirected (Directed _ tfa _) = tfa
+
-- Stage of compilation. Parts of the AST maybe un unavailable with other stages
-- as compilation simplifies the AST.
data Stage = Stage1 | Stage2 | Stage3
@@ -32,8 +98,10 @@ data Stage = Stage1 | Stage2 | Stage3
-- Root of the parse tree. Just contains a list of declarations.
data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where
- FiddleUnit :: [FiddleDecl stage f a] -> a -> FiddleUnit stage f a
- deriving (Generic, Annotated, Alter, Typeable)
+ FiddleUnit :: [Directed (FiddleDecl stage) f a] -> a -> FiddleUnit stage f a
+ deriving (Generic, Annotated, Typeable)
+
+deriving instance (Alter (ImportType stage)) => Alter (FiddleUnit stage)
-- Just an identifier.
data Identifier f a = Identifier !Text a
@@ -45,6 +113,24 @@ data Expression stage f a where
LitNum :: NumberType stage -> a -> Expression stage f a
Var :: Identifier f a -> a -> Expression stage f a
+-- Wrapper class because using a type family like "ImportType" means I cannot
+-- derive classes. I'd rather only derive for this class than have to derive for
+-- the whole PackageBody class.
+data ImportTypeWrapper stage f a where
+ ImportTypeWrapper :: ImportType stage f a -> ImportTypeWrapper stage f a
+
+instance (Alter (ImportType stage)) => Alter (ImportTypeWrapper stage) where
+ alter ffn fn (ImportTypeWrapper st) =
+ ImportTypeWrapper <$> alter ffn fn st
+
+data ImportStatement f a where
+ ImportStatement :: Text -> Maybe (ImportList f a) -> a -> ImportStatement f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data ImportList f a where
+ ImportList :: [Identifier f a] -> a -> ImportList f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
-- Top-level declarations.
data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where
{-
@@ -56,6 +142,10 @@ data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where
Identifier f a ->
a ->
FiddleDecl stage f a
+ ImportDecl ::
+ ImportType stage f a ->
+ a ->
+ FiddleDecl stage f a
{- Package Statement. Package Name, Package body -}
PackageDecl ::
Identifier f a ->
@@ -87,10 +177,16 @@ data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where
ObjType stage f a ->
a ->
FiddleDecl stage f a
- deriving (Generic, Annotated, Alter, Typeable)
+ deriving (Generic, Annotated, Typeable)
+
+deriving instance (Alter (ImportType stage)) => Alter (FiddleDecl stage)
data ObjTypeBody (stage :: Stage) (f :: Type -> Type) a where
- ObjTypeBody :: BodyType f a -> [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a
+ ObjTypeBody ::
+ BodyType f a ->
+ [Directed (ObjTypeDecl stage) f a] ->
+ a ->
+ ObjTypeBody stage f a
deriving (Generic, Annotated, Alter, Typeable)
data ObjType stage f a where
@@ -139,7 +235,7 @@ data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read, Typeable)
data DeferredRegisterBody stage f a where
DeferredRegisterBody ::
- [RegisterBitsDecl stage f a] ->
+ [Directed (RegisterBitsDecl stage) f a] ->
a ->
DeferredRegisterBody stage f a
deriving (Generic, Annotated, Alter, Typeable)
@@ -150,7 +246,11 @@ data BodyType (f :: Type -> Type) a where
deriving (Generic, Annotated, Alter, Typeable)
data RegisterBody stage f a where
- RegisterBody :: BodyType f a -> f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a
+ RegisterBody ::
+ BodyType f a ->
+ f (DeferredRegisterBody stage f a) ->
+ a ->
+ RegisterBody stage f a
deriving (Generic, Annotated, Alter, Typeable)
data RegisterBitsDecl stage f a where
@@ -207,7 +307,8 @@ instance Annotated (Expression stage) where
instance Alter (ObjTypeDecl stage) where
alter ffn fn = \case
- (AssertPosStatement expr a) -> AssertPosStatement <$> alter ffn fn expr <*> fn a
+ (AssertPosStatement expr a) ->
+ AssertPosStatement <$> alter ffn fn expr <*> fn a
(RegisterDecl mMod mIdent expr mBody a) ->
RegisterDecl
<$> mapM (alter ffn fn) mMod
@@ -285,20 +386,29 @@ data BitType (stage :: Stage) (f :: Type -> Type) a where
data EnumBody (stage :: Stage) (f :: Type -> Type) a where
-- <decl>,
- EnumBody :: [EnumConstantDecl stage f a] -> a -> EnumBody stage f a
+ EnumBody :: [Directed (EnumConstantDecl stage) f a] -> a -> EnumBody stage f a
deriving (Generic, Annotated, Alter, Typeable)
data EnumConstantDecl stage f a where
-- <ident> = <expr>
- EnumConstantDecl :: Identifier f a -> Expression stage f a -> a -> EnumConstantDecl stage f a
+ EnumConstantDecl ::
+ Identifier f a ->
+ Expression stage f a ->
+ a ->
+ EnumConstantDecl stage f a
-- reserved = <expr>
- EnumConstantReserved :: Expression stage f a -> a -> EnumConstantDecl stage f a
+ EnumConstantReserved ::
+ Expression stage f a ->
+ a ->
+ EnumConstantDecl stage f a
deriving (Generic, Annotated, Alter, Typeable)
data PackageBody (stage :: Stage) (f :: Type -> Type) a where
{- The body of a package -}
- PackageBody :: [FiddleDecl stage f a] -> a -> PackageBody stage f a
- deriving (Generic, Annotated, Alter, Typeable)
+ PackageBody :: [Directed (FiddleDecl stage) f a] -> a -> PackageBody stage f a
+ deriving (Generic, Annotated, Typeable)
+
+deriving instance (Alter (ImportType stage)) => Alter (PackageBody stage)
-- instance Alter (Modifier stage) where
-- alter _ fn (ModifierKeyword m a) = ModifierKeyword m (fn a)
@@ -315,7 +425,7 @@ data PackageBody (stage :: Stage) (f :: Type -> Type) a where
proxyOf :: t f a -> Proxy t
proxyOf _ = Proxy
-class Annotated (t :: (Type -> Type) -> Type -> Type) where
+class Annotated (t :: SynTreeKind) 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)
@@ -336,7 +446,7 @@ instance (GAnnot a r, GAnnot a l) => GAnnot a (l :+: r) where
instance (GAnnot a r) => GAnnot a (M1 i c r) where
gannot (M1 a) = gannot a
-class Alter (t :: (Type -> Type) -> Type -> Type) where
+class Alter (t :: SynTreeKind) where
alter ::
forall f1 f2 a1 a2 m.
(Monad m, Traversable f1) =>
@@ -384,13 +494,19 @@ instance GAlter t f1 f2 a1 a2 (Rec0 u1) (Rec0 u1) where
galter _ _ _ = return
{- Recursive case. Call alter on sub-structures. -}
-instance (Alter u) => GAlter t f1 f2 a1 a2 (Rec0 (u f1 a1)) (Rec0 (u f2 a2)) where
+instance
+ (Alter u) =>
+ GAlter t f1 f2 a1 a2 (Rec0 (u f1 a1)) (Rec0 (u f2 a2))
+ where
galter _ ffn fn k1 =
K1 <$> alter ffn fn (unK1 k1)
{- Recursive case. Called when there are list of substructures that need to be
recused. -}
-instance (Alter u, Traversable l) => GAlter t f1 f2 a1 a2 (Rec0 (l (u f1 a1))) (Rec0 (l (u f2 a2))) where
+instance
+ (Alter u, Traversable l) =>
+ GAlter t f1 f2 a1 a2 (Rec0 (l (u f1 a1))) (Rec0 (l (u f2 a2)))
+ where
galter _ ffn fn k1 =
K1 <$> mapM (alter ffn fn) (unK1 k1)
diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs
index 25ee66b..2e3acbc 100644
--- a/src/Language/Fiddle/Compiler/Stage1.hs
+++ b/src/Language/Fiddle/Compiler/Stage1.hs
@@ -68,7 +68,7 @@ toStage2 (FiddleUnit decls annot) = do
FiddleUnit <$> reconfigureFiddleDecls (Path []) decls <*> pure annot
return a
-reconfigureFiddleDecls :: Path -> [FiddleDecl Stage1 I Annot] -> M Annot [FiddleDecl Stage2 I Annot]
+reconfigureFiddleDecls :: Path -> [Directed (FiddleDecl Stage1) I Annot] -> M Annot [Directed (FiddleDecl Stage2) I Annot]
reconfigureFiddleDecls p decls = do
-- (Stage2CompilerState anonymousObjTypes anonymousBitsTypes, decls) <- pushState $ do
-- put (Stage2CompilerState [] [])
@@ -76,13 +76,13 @@ reconfigureFiddleDecls p decls = do
lastState <- get
put (Stage2CompilerState [] [])
- decls <- mapM (fiddleDeclToStage2 p) decls
+ decls <- mapM (mapDirectedM $ fiddleDeclToStage2 p) decls
(Stage2CompilerState anonymousObjTypes anonymousBitsTypes) <- get
put lastState
return $
- map resolveAnonymousObjType anonymousObjTypes
- ++ map resolveAnonymousBitsType anonymousBitsTypes
+ map (asDirected . resolveAnonymousObjType) anonymousObjTypes
+ ++ map (asDirected . resolveAnonymousBitsType) anonymousBitsTypes
++ decls
where
resolveAnonymousObjType (Linkage linkage, objTypeBody) =
@@ -104,6 +104,7 @@ fiddleDeclToStage2 path decl = do
(LocationDecl i expr a) -> LocationDecl i <$> toStage2Expr expr <*> pure a
(BitsDecl i typ a) -> BitsDecl i <$> bitsTypeToStage2 (pushId i path) typ <*> pure a
(ObjTypeDecl i body a) -> ObjTypeDecl i <$> mapM (objTypeBodyToStage2 (pushId i path)) body <*> pure a
+ (ImportDecl importStatement a) -> return $ ImportDecl importStatement a
(ObjectDecl i expr typ a) ->
ObjectDecl i <$> toStage2Expr expr <*> objectTypeToStage2 (pushId i path) typ <*> pure a
@@ -115,7 +116,7 @@ bitsTypeToStage2 path = \case
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
+ EnumBody constants a -> EnumBody <$> mapM (mapDirectedM (enumConstantToStage2 path)) constants <*> pure a
enumConstantToStage2 :: Path -> EnumConstantDecl Stage1 I Annot -> M Annot (EnumConstantDecl Stage2 I Annot)
enumConstantToStage2 path = \case
@@ -124,7 +125,7 @@ enumConstantToStage2 path = \case
objTypeBodyToStage2 :: Path -> ObjTypeBody Stage1 I Annot -> M Annot (ObjTypeBody Stage2 I Annot)
objTypeBodyToStage2 path (ObjTypeBody bodyType decls annot) =
- ObjTypeBody bodyType <$> mapM (objTypeDeclToStage2 path) decls <*> pure annot
+ ObjTypeBody bodyType <$> mapM (mapDirectedM $ objTypeDeclToStage2 path) decls <*> pure annot
objTypeDeclToStage2 :: Path -> ObjTypeDecl Stage1 I Annot -> M Annot (ObjTypeDecl Stage2 I Annot)
objTypeDeclToStage2 path = \case
@@ -150,7 +151,7 @@ registerBodyToStage2 :: Path -> RegisterBody Stage1 I Annot -> M Annot (Register
registerBodyToStage2 path (RegisterBody bodyType (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) =
RegisterBody bodyType . Identity
<$> ( DeferredRegisterBody
- <$> mapM (registerBitsDeclToStage2 path) registerBitsDecl
+ <$> mapM (mapDirectedM $ registerBitsDeclToStage2 path) registerBitsDecl
<*> pure a1
)
<*> pure a2
diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs
index 727f153..431fc76 100644
--- a/src/Language/Fiddle/Compiler/Stage2.hs
+++ b/src/Language/Fiddle/Compiler/Stage2.hs
@@ -72,7 +72,7 @@ toStage3 (FiddleUnit decls a) =
snd
<$> subCompile
emptyState
- ( FiddleUnit <$> mapM fiddleDeclToStage3 decls <*> pure a
+ ( FiddleUnit <$> mapM (mapDirectedM fiddleDeclToStage3) decls <*> pure a
)
exprToSize ::
@@ -94,7 +94,7 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
when (declaredSize <= 4) $ do
imap <-
foldlM
- ( \imap enumConst -> do
+ ( \imap (undirected -> enumConst) -> do
number <- case enumConst of
EnumConstantDecl _ expr _ -> exprToSize expr
EnumConstantReserved expr _ -> exprToSize expr
@@ -137,6 +137,7 @@ fiddleDeclToStage3 = \case
BitsDecl id <$> bitTypeToStage3 typ <*> pure a
ObjTypeDecl ident body a ->
ObjTypeDecl ident <$> mapM (\bt -> fst <$> objTypeBodyToStage3 bt 0) body <*> pure a
+ ImportDecl importStatement a -> return $ ImportDecl importStatement a
ObjectDecl ident expr typ a ->
ObjectDecl ident (expressionToStage3 expr) <$> objTypeToStage3 typ <*> pure a
@@ -162,10 +163,10 @@ registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a')
(cur, returned) <-
foldlM
( \(cursor, returned) decl ->
- case decl of
+ case undirected decl of
ReservedBits expr a -> do
size <- fromIntegral <$> exprToSize expr
- let s3 = ReservedBits (expressionToStage3 expr) a
+ let s3 = mapDirected (const $ ReservedBits (expressionToStage3 expr) a) decl
if isUnion
then checkUnion cursor size (s3 : returned) a
else
@@ -174,7 +175,7 @@ registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a')
checkBitsSubStructure registerBody maybeIdent annot
(newBody, subsize) <- registerBodyToStage3 registerBody
- let s3 = BitsSubStructure newBody maybeIdent annot
+ let s3 = mapDirected (const $ BitsSubStructure newBody maybeIdent annot) decl
if isUnion
then checkUnion cursor subsize (s3 : returned) a
@@ -182,7 +183,7 @@ registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a')
return (cursor + subsize, s3 : returned)
DefinedBits modifier identifier typeref a -> do
(s3TypeRef, size) <- registerBitsTypeRefToStage3 typeref
- let s3 = DefinedBits modifier identifier s3TypeRef a
+ let s3 = mapDirected (const $ DefinedBits modifier identifier s3TypeRef a) decl
if isUnion
then checkUnion cursor size (s3 : returned) a
@@ -265,18 +266,22 @@ objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
(cur, returned) <-
foldlM
( \(cursor, returned) decl ->
- case decl of
+ case undirected decl of
RegisterDecl mMod mIdent expr mBody a -> do
(s3RegisterBody, mCalculatedSize) <-
fUnzip <$> mapM registerBodyToStage3 mBody
let s3 =
- RegisterDecl
- mMod
- mIdent
- (expressionToStage3 expr)
- s3RegisterBody
- a
+ mapDirected
+ ( const $
+ RegisterDecl
+ mMod
+ mIdent
+ (expressionToStage3 expr)
+ s3RegisterBody
+ a
+ )
+ decl
declaredSizeBits <- fromIntegral <$> exprToSize expr
@@ -320,7 +325,7 @@ objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
subBody
( if isUnion then startOff else cursor
)
- let s3 = TypeSubStructure (Identity newBody) maybeIdent annot
+ let s3 = mapDirected (const $ TypeSubStructure (Identity newBody) maybeIdent annot) decl
checkTypesSubStructure subBody maybeIdent annot
if isUnion
@@ -338,7 +343,7 @@ objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
(unCommented a)
]
let size = size' `div` 8
- let s3 = ReservedDecl (expressionToStage3 expr) annot
+ let s3 = mapDirected (const $ ReservedDecl (expressionToStage3 expr) annot) decl
if isUnion
then
checkUnion cursor size (s3 : returned) a
@@ -406,7 +411,7 @@ bitTypeToStage3 (EnumBitType expr body a) =
enumBodyToStage3 :: EnumBody Stage2 I Annot -> Compile Stage3State (EnumBody Stage3 I Annot)
enumBodyToStage3 (EnumBody constants a) =
- EnumBody <$> mapM enumConstantDeclToStage3 constants <*> pure a
+ EnumBody <$> mapM (mapDirectedM enumConstantDeclToStage3) constants <*> pure a
enumConstantDeclToStage3 :: EnumConstantDecl Stage2 I Annot -> Compile Stage3State (EnumConstantDecl Stage3 I Annot)
enumConstantDeclToStage3 = \case
@@ -415,4 +420,4 @@ enumConstantDeclToStage3 = \case
packageBodyToStage3 :: PackageBody Stage2 I Annot -> Compile Stage3State (PackageBody Stage3 I Annot)
packageBodyToStage3 (PackageBody decls a) =
- PackageBody <$> mapM fiddleDeclToStage3 decls <*> pure a
+ PackageBody <$> mapM (mapDirectedM fiddleDeclToStage3) decls <*> pure a
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 00824ed..46c0594 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -28,7 +28,12 @@ import Language.Fiddle.Types
import Text.Parsec.Pos
import Text.Printf (printf)
-type Context stage = (Show (NumberType stage), Typeable stage)
+type Context stage =
+ ( Show (NumberType stage),
+ Typeable stage,
+ ToGenericSyntaxTree (ImportType stage),
+ Typeable (ImportType stage)
+ )
data GenericSyntaxTree f a where
{- GenericSyntaxtTree with a name and children. -}
@@ -94,7 +99,7 @@ instance ToGenericSyntaxTreeValue Data.Text.Text where
type GenericContext t f a = (Traversable f, ToGenericSyntaxTree t, Typeable t, Typeable f, Typeable a)
-class ToGenericSyntaxTree (t :: (Type -> Type) -> Type -> Type) where
+class ToGenericSyntaxTree (t :: SynTreeKind) where
toGenericSyntaxTree :: (Traversable f, Typeable f, Typeable t, Typeable a) => t f a -> GenericSyntaxTree f a
default toGenericSyntaxTree ::
(GenericContext t f a, Generic (t f a), (GToGenericSyntaxTree (Rep (t f a)) f a)) =>
@@ -176,6 +181,20 @@ deriving instance (ToGenericSyntaxTree Identifier)
deriving instance (ToGenericSyntaxTree BodyType)
+deriving instance (ToGenericSyntaxTree Directive)
+
+deriving instance (ToGenericSyntaxTree DirectiveBody)
+
+deriving instance (ToGenericSyntaxTree DirectiveElement)
+
+deriving instance (ToGenericSyntaxTree DirectiveExpression)
+
+deriving instance (ToGenericSyntaxTree ImportList)
+
+deriving instance (ToGenericSyntaxTree ImportStatement)
+
+deriving instance (ToGenericSyntaxTree t, Typeable t) => (ToGenericSyntaxTree (Directed t))
+
deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleUnit stage))
deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleDecl stage))
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index 7eed0f2..f3ad744 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -7,6 +7,7 @@ module Language.Fiddle.Parser
)
where
+import Control.Monad (void)
import Data.Functor.Identity
import Data.Kind (Type)
import Data.Text (Text)
@@ -50,25 +51,89 @@ isComment (Token t _) =
stripTrailingComments :: [Token s] -> [Token s]
stripTrailingComments = reverse . dropWhile isComment . reverse
+directed :: Pa t -> PaS (Directed (t 'Stage1))
+directed subparser = withMeta $ do
+ Directed <$> many directive <*> subparser
+
+directive :: PaS Directive
+directive =
+ withMeta $
+ Directive <$> defer directiveBodyTokens directiveBody
+
+directiveBody :: PaS DirectiveBody
+directiveBody = withMeta $ do
+ DirectiveBody <$> many (directiveElement <* (void (tok TokComma) <|> eof))
+
+directiveElement :: PaS DirectiveElement
+directiveElement = withMeta $ do
+ identifier1 <- nextText
+ choice
+ [ do
+ tok TokColon
+ let backend = identifier1
+ key <- nextText
+ choice
+ [ do
+ tok TokEq
+ DirectiveElementKeyValue (Just backend) key <$> directiveExpression,
+ do
+ return (DirectiveElementKey (Just backend) key)
+ ],
+ do
+ tok TokEq
+ let key = identifier1
+ DirectiveElementKeyValue Nothing key <$> directiveExpression,
+ return $ DirectiveElementKey Nothing identifier1
+ ]
+
+nextText :: PaS Identifier
+nextText = withMeta $ Identifier <$> token textOf
+
+directiveExpression :: PaS DirectiveExpression
+directiveExpression = withMeta $ do
+ choice
+ [ do
+ token $ \case
+ (TokString str) -> Just $ DirectiveString str
+ (TokLitNum num) -> Just $ DirectiveNumber num
+ _ -> Nothing
+ ]
+
fiddleUnit :: Pa FiddleUnit
fiddleUnit = do
withMeta
- ( FiddleUnit <$> many1 (fiddleDecl <* tok TokSemi)
+ ( FiddleUnit <$> many1 (directed fiddleDecl <* tok TokSemi)
)
<* many comment
+stringToken :: P Text
+stringToken = token (\case
+ (TokString str) -> Just str
+ _ -> Nothing)
+
+importList :: PaS ImportList
+importList = withMeta $ do
+ tok TokLParen
+ ImportList <$> many (ident <* (tok TokComma <|> lookAhead (tok TokRParen)))
+ <* tok TokRParen
+
+importStatement :: PaS ImportStatement
+importStatement = withMeta $
+ ImportStatement <$> stringToken <*> optionMaybe importList
+
fiddleDecl :: Pa FiddleDecl
fiddleDecl = do
withMeta $ do
t <- tokenType <$> anyToken
case t of
- KWOption -> OptionDecl <$> ident <*> ident
+ KWOption -> OptionDecl <$> nextText <*> nextText
KWPackage ->
PackageDecl
<$> ident
<*> defer body packageBody
KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expression)
KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitType)
+ KWImport -> ImportDecl <$> importStatement
KWType ->
ObjTypeDecl
<$> ident
@@ -132,7 +197,7 @@ exprInParen = tok TokLParen *> expression <* tok TokRParen
objTypeBody :: BodyType F (Commented SourceSpan) -> Pa ObjTypeBody
objTypeBody bt =
withMeta $
- ObjTypeBody bt <$> many (objTypeDecl <* tok TokSemi)
+ ObjTypeBody bt <$> many (directed objTypeDecl <* tok TokSemi)
objTypeDecl :: Pa ObjTypeDecl
objTypeDecl =
@@ -185,7 +250,7 @@ registerBody = withMeta $ RegisterBody <$> bitBodyType <*> defer body deferredRe
deferredRegisterBody :: Pa DeferredRegisterBody
deferredRegisterBody =
withMeta $
- DeferredRegisterBody <$> many (registerBitsDecl <* tok TokSemi)
+ DeferredRegisterBody <$> many (directed registerBitsDecl <* tok TokSemi)
registerBitsDecl :: Pa RegisterBitsDecl
registerBitsDecl =
@@ -239,7 +304,7 @@ bitType = withMeta $ rawBits <|> enumType
enumBody :: Pa EnumBody
enumBody =
withMeta $
- EnumBody <$> many (enumConstantDecl <* tok TokComma)
+ EnumBody <$> many (directed enumConstantDecl <* tok TokComma)
enumConstantDecl :: Pa EnumConstantDecl
enumConstantDecl =
@@ -260,6 +325,13 @@ body = do
(_, b, _) <- body'
return b
+directiveBodyTokens :: P [Token SourceSpan]
+directiveBodyTokens = do
+ tokKeepComment TokDirectiveStart
+ ret <- concat <$> manyTill ((: []) <$> anyToken) (lookAhead $ tokKeepComment TokDirectiveEnd)
+ tokKeepComment TokDirectiveEnd
+ return ret
+
body' :: P (Token SourceSpan, [Token SourceSpan], Token SourceSpan)
body' = do
l <- tokKeepComment TokLBrace
@@ -299,9 +371,10 @@ packageBody =
withMeta $
PackageBody
<$> many
- ( fiddleDecl
- <* ( tok TokSemi <|> fail "Expected ';'"
- )
+ ( directed $
+ fiddleDecl
+ <* ( tok TokSemi <|> fail "Expected ';'"
+ )
)
printNext :: P ()
diff --git a/src/Language/Fiddle/Tokenizer.hs b/src/Language/Fiddle/Tokenizer.hs
index 08f5649..87f119f 100644
--- a/src/Language/Fiddle/Tokenizer.hs
+++ b/src/Language/Fiddle/Tokenizer.hs
@@ -27,6 +27,7 @@ data T
| KWType
| KWUnion
| KWWo
+ | KWImport
| TokColon
| TokComma
| TokComment !Text
@@ -41,8 +42,35 @@ data T
| TokRBracket
| TokRParen
| TokSemi
+ | TokString !Text
+ | TokDirectiveStart -- [[
+ | TokDirectiveEnd -- ]]
deriving (Eq, Ord, Show, Read)
+textOf :: T -> Maybe Text
+textOf t = do
+ case t of
+ KWAssertPos -> Just "assert_pos"
+ KWAt -> Just "at"
+ KWBits -> Just "bits"
+ KWEnum -> Just "enum"
+ KWInstance -> Just "instance"
+ KWLocation -> Just "location"
+ KWOption -> Just "option"
+ KWPackage -> Just "package"
+ KWReg -> Just "reg"
+ KWReserved -> Just "reserved"
+ KWRo -> Just "ro"
+ KWRw -> Just "rw"
+ KWStruct -> Just "struct"
+ KWType -> Just "type"
+ KWUnion -> Just "union"
+ KWWo -> Just "wo"
+ KWImport -> Just "import"
+ TokIdent i -> Just i
+ TokLitNum n -> Just n
+ _ -> Nothing
+
data Token a = Token !T a
deriving (Eq, Ord, Show, Functor)
@@ -66,6 +94,7 @@ parseToken = spaces *> tok parseToken' <* spaces
"type" -> KWType
"option" -> KWOption
"package" -> KWPackage
+ "import" -> KWImport
"reg" -> KWReg
"ro" -> KWRo
"wo" -> KWWo
@@ -77,6 +106,19 @@ parseToken = spaces *> tok parseToken' <* spaces
(Data.Text.head -> h) | isDigit h -> TokLitNum str
ident -> TokIdent ident
+ parseString = fmap (TokString . Data.Text.pack . concat) $ do
+ char '"'
+ manyTill
+ ( do
+ c <- anyChar
+ if c == '\\'
+ then do
+ c2 <- anyChar
+ return [c, c2]
+ else return [c]
+ )
+ (char '"')
+
parseComment =
try
( do
@@ -91,7 +133,9 @@ parseToken = spaces *> tok parseToken' <* spaces
parseSymbol =
choice
- [ char ':' $> TokColon,
+ [ try (string "[[" $> TokDirectiveStart),
+ try (string "]]" $> TokDirectiveEnd),
+ char ':' $> TokColon,
char ',' $> TokComma,
char '=' $> TokEq,
char '{' $> TokLBrace,
@@ -107,6 +151,7 @@ parseToken = spaces *> tok parseToken' <* spaces
parseToken' =
fmap (parseAlNumTok . Data.Text.pack) (many1 (alphaNum <|> char '_'))
+ <|> parseString
<|> parseComment
<|> parseSymbol
diff --git a/vim/syntax/fiddle.vim b/vim/syntax/fiddle.vim
index 7d36e93..70a3f26 100644
--- a/vim/syntax/fiddle.vim
+++ b/vim/syntax/fiddle.vim
@@ -13,9 +13,24 @@ syn match FiddleIdent +[A-Za-z0-9_]\++ contained
syn match FiddleComment +\/\/.*$+
syn region FiddleDocComment start=+/\*\*+ end=+*/+
+syn region FiddleString start=+"+ end=+"+ skip=+\\.+
+
+syn region FiddleDirective start=+\[\[+ end=+\]\]+ contains=FiddleString
syn match FiddleNumber +\<[0-9_]\+\([xb]\)\@!\|0x[0-9A-Fa-f][0-9A-Fa-f_]*\|0b[01]\+\>+
+syn match FiddleImport +import+ nextgroup=FiddleImportString skipwhite
+syn region FiddleImportString start=+"+ end=+"+ skip=+\\.+ skipwhite nextgroup=FiddleImportList contained
+syn region FiddleImportList start=+(+ end=+)+ skipwhite contained contains=FiddleImportValue
+syn match FiddleImportValue +[a-zA-Z0-9_]\++ contained
+
+hi! link FiddleImportString FiddleString
+hi! link FiddleImportList PreProc
+hi! link FiddleImportValue Type
+hi! link FiddleImport FiddleStorageClass
+
+hi! link FiddleString String
+hi! link FiddleDirective PreProc
hi! link FiddleContainedType Type
hi! link FiddleModifier StorageClass
hi! link FiddleBuiltin Function
generated by cgit (git 2.34.1) at 2025-07-02 05:20:54 +0000