diff options
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast.hs | 170 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler.hs | 80 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage0.hs | 2 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage1.hs | 220 | ||||
| -rw-r--r-- | src/Language/Fiddle/GenericTree.hs | 149 | ||||
| -rw-r--r-- | src/Language/Fiddle/Parser.hs | 3 | ||||
| -rw-r--r-- | src/Language/Fiddle/Types.hs | 2 | ||||
| -rw-r--r-- | src/Main.hs | 4 | ||||
| -rw-r--r-- | stack.yaml | 2 | ||||
| -rw-r--r-- | vim/syntax/fiddle.vim | 2 |
11 files changed, 424 insertions, 211 deletions
diff --git a/package.yaml b/package.yaml index 2ca3b73..2f78def 100644 --- a/package.yaml +++ b/package.yaml @@ -33,3 +33,4 @@ dependencies: - vector - bytestring - data-default + - transformers diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs index 61a637e..277ab24 100644 --- a/src/Language/Fiddle/Ast.hs +++ b/src/Language/Fiddle/Ast.hs @@ -9,45 +9,41 @@ module Language.Fiddle.Ast where import Data.Functor.Identity +import Data.Kind (Type) import Data.Proxy import Data.Text (Text) import Data.Traversable +import Data.Typeable import GHC.Generics +import GHC.TypeLits + +type family NumberType (a :: Stage) where + NumberType Stage1 = Text + NumberType Stage2 = Integer + NumberType Stage3 = Integer -- Stage of compilation. Parts of the AST maybe un unavailable with other stages -- as compilation simplifies the AST. data Stage = Stage1 | Stage2 | Stage3 + deriving (Typeable) + +-- 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) -- Just an identifier. data Identifier stage f a = Identifier !Text a - deriving (Generic, Annotated, Alter) + deriving (Generic, Annotated, Alter, Typeable) -- Expression. data Expression stage f a where -- Just a string. Parsing the number comes in stage2. - LitNum :: Text -> a -> Expression 'Stage1 f a - RealNum :: Integer -> a -> Expression 'Stage2 f a + LitNum :: NumberType stage -> a -> Expression stage f a Var :: Identifier stage f a -> a -> Expression stage f a -instance Alter (Expression stage) where - alter ffn fn = \case - LitNum t a -> LitNum t <$> fn a - RealNum i a -> RealNum i <$> fn a - Var i a -> Var <$> alter ffn fn i <*> fn a - -instance Annotated (Expression stage) where - annot = \case - LitNum _ a -> a - RealNum _ a -> a - Var _ a -> a - --- Root of the parse tree. Just contains a list of declarations. -data FiddleUnit (stage :: Stage) (f :: * -> *) a where - FiddleUnit :: [FiddleDecl stage f a] -> a -> FiddleUnit stage f a - deriving (Generic, Annotated, Alter) - -- Top-level declarations. -data FiddleDecl (stage :: Stage) (f :: * -> *) a where +data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where {- - An option is a key/value pair. - option <ident> <ident>; @@ -88,7 +84,11 @@ data FiddleDecl (stage :: Stage) (f :: * -> *) a where ObjType stage f a -> a -> FiddleDecl stage f a - deriving (Generic, Annotated, Alter) + deriving (Generic, Annotated, Alter, Typeable) + +data ObjTypeBody (stage :: Stage) (f :: Type -> Type) a where + ObjTypeBody :: [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a + deriving (Generic, Annotated, Alter, Typeable) data ObjType stage f a where -- { <body> } @@ -99,29 +99,15 @@ data ObjType stage f a where ArrayObjType :: ObjType stage f a -> Expression stage f a -> a -> ObjType stage f a -- <identifier> ReferencedObjType :: Identifier stage f a -> a -> ObjType stage f a - -instance Alter (ObjType stage) where - alter ffn fn = \case - (AnonymousObjType b a) -> - AnonymousObjType <$> (ffn =<< mapM (alter ffn fn) b) <*> fn a - (ArrayObjType t e a) -> - ArrayObjType <$> alter ffn fn t <*> alter ffn fn e <*> fn a - (ReferencedObjType i a) -> - ReferencedObjType <$> alter ffn fn i <*> fn a - -instance Annotated (ObjType stage) where - annot = \case - (AnonymousObjType _ a) -> a - (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) + deriving (Typeable) data ObjTypeDecl stage f a where {- assert_pos(<expr>) -} - AssertPosStatement :: Expression stage f a -> a -> ObjTypeDecl stage f a + AssertPosStatement :: + (CmpNat (StageNumber stage) 3 ~ LT) => + Expression stage f a -> + a -> + ObjTypeDecl stage f a {- reg <ident>(<expr>) : <regtype> -} RegisterDecl :: Maybe (Modifier stage f a) -> @@ -130,24 +116,24 @@ data ObjTypeDecl stage f a where Maybe (RegisterBody stage f a) -> a -> ObjTypeDecl stage f a - deriving (Generic, Annotated, Alter) + deriving (Typeable) data Modifier stage f a where ModifierKeyword :: ModifierKeyword -> a -> Modifier stage f a - deriving (Generic, Annotated, Alter) + deriving (Generic, Annotated, Alter, Typeable) -data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read) +data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read, Typeable) data DeferredRegisterBody stage f a where DeferredRegisterBody :: [RegisterBitsDecl stage f a] -> a -> DeferredRegisterBody stage f a - deriving (Generic, Annotated, Alter) + deriving (Generic, Annotated, Alter, Typeable) data RegisterBody stage f a where RegisterBody :: f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a - deriving (Generic, Annotated, Alter) + deriving (Generic, Annotated, Alter, Typeable) data RegisterBitsDecl stage f a where -- reserved(<expr>) @@ -159,19 +145,7 @@ 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) + deriving (Generic, Annotated, Alter, Typeable) data RegisterBitsTypeRef stage f a where -- <type>[<expr>] @@ -186,7 +160,7 @@ data RegisterBitsTypeRef stage f a where Anonymous types are only allowed in stage1. Stage2 should de-anonymize these type. -} RegisterBitsAnonymousType :: - AnonymousBitsType stage f a -> + AnonymousBitsType Stage1 f a -> a -> RegisterBitsTypeRef 'Stage1 f a {- (<expr>) @@ -198,6 +172,47 @@ data RegisterBitsTypeRef stage f a where a -> RegisterBitsTypeRef stage f a +instance Alter (Expression stage) where + alter ffn fn = \case + LitNum t a -> LitNum t <$> fn a + Var i a -> Var <$> alter ffn fn i <*> fn a + +instance Annotated (Expression stage) where + annot = \case + LitNum _ a -> a + Var _ a -> a + +instance Alter (ObjTypeDecl stage) where + alter ffn fn = \case + (AssertPosStatement expr a) -> AssertPosStatement <$> alter ffn fn expr <*> fn a + (RegisterDecl mMod mIdent expr mBody a) -> + RegisterDecl + <$> mapM (alter ffn fn) mMod + <*> mapM (alter ffn fn) mIdent + <*> alter ffn fn expr + <*> mapM (alter ffn fn) mBody + <*> fn a + +instance Annotated (ObjTypeDecl stage) where + annot = \case + (AssertPosStatement _ a) -> a + (RegisterDecl _ _ _ _ a) -> a + +instance Alter (ObjType stage) where + alter ffn fn = \case + (AnonymousObjType b a) -> + AnonymousObjType <$> (ffn =<< mapM (alter ffn fn) b) <*> fn a + (ArrayObjType t e a) -> + ArrayObjType <$> alter ffn fn t <*> alter ffn fn e <*> fn a + (ReferencedObjType i a) -> + ReferencedObjType <$> alter ffn fn i <*> fn a + +instance Annotated (ObjType stage) where + annot = \case + (AnonymousObjType _ a) -> a + (ArrayObjType _ _ a) -> a + (ReferencedObjType _ a) -> a + instance Alter (RegisterBitsTypeRef stage) where alter ffn fn = \case (RegisterBitsArray ref exp a) -> @@ -218,10 +233,14 @@ instance Annotated (RegisterBitsTypeRef stage) where data AnonymousBitsType stage f a where -- enum(<expr>) { <body> } - AnonymousEnumBody :: Expression stage f a -> f (EnumBody stage f a) -> a -> AnonymousBitsType stage f a - deriving (Generic, Annotated, Alter) + AnonymousEnumBody :: + Expression stage f a -> + f (EnumBody stage f a) -> + a -> + AnonymousBitsType stage f a + deriving (Generic, Annotated, Alter, Typeable) -data BitType (stage :: Stage) (f :: * -> *) a where +data BitType (stage :: Stage) (f :: Type -> Type) a where -- enum(<expr>) { <body> } EnumBitType :: Expression stage f a -> @@ -230,24 +249,24 @@ data BitType (stage :: Stage) (f :: * -> *) a where BitType stage f a -- (<expr>) RawBits :: Expression stage f a -> a -> BitType stage f a - deriving (Generic, Annotated, Alter) + deriving (Generic, Annotated, Alter, Typeable) -data EnumBody (stage :: Stage) (f :: * -> *) a where +data EnumBody (stage :: Stage) (f :: Type -> Type) a where -- <decl>, EnumBody :: [EnumConstantDecl stage f a] -> a -> EnumBody stage f a - deriving (Generic, Annotated, Alter) + deriving (Generic, Annotated, Alter, Typeable) data EnumConstantDecl stage f a where -- <ident> = <expr> EnumConstantDecl :: Identifier stage f a -> Expression stage f a -> a -> EnumConstantDecl stage f a -- reserved = <expr> EnumConstantReserved :: Expression stage f a -> a -> EnumConstantDecl stage f a - deriving (Generic, Annotated, Alter) + deriving (Generic, Annotated, Alter, Typeable) -data PackageBody (stage :: Stage) (f :: * -> *) a where +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) + deriving (Generic, Annotated, Alter, Typeable) -- instance Alter (Modifier stage) where -- alter _ fn (ModifierKeyword m a) = ModifierKeyword m (fn a) @@ -264,7 +283,7 @@ data PackageBody (stage :: Stage) (f :: * -> *) a where proxyOf :: t f a -> Proxy t proxyOf _ = Proxy -class Annotated (t :: (* -> *) -> * -> *) where +class Annotated (t :: (Type -> Type) -> Type -> Type) 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) @@ -273,7 +292,7 @@ class GAnnot a r where gannot :: r x -> a instance GAnnot a (Rec0 a) where - gannot k1 = unK1 k1 + gannot = unK1 instance (GAnnot a r) => GAnnot a (l :*: r) where gannot (_ :*: r) = gannot r @@ -285,7 +304,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 :: (* -> *) -> * -> *) where +class Alter (t :: (Type -> Type) -> Type -> Type) where alter :: forall f1 f2 a1 a2 m. (Monad m, Traversable f1) => @@ -382,6 +401,11 @@ instance where galter proxy ffn fn (M1 a) = M1 <$> galter proxy ffn fn a +type family StageNumber (s :: Stage) :: Natural where + StageNumber Stage1 = 1 + StageNumber Stage2 = 2 + StageNumber Stage3 = 3 + {--} 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/Compiler.hs b/src/Language/Fiddle/Compiler.hs index 8d8d65c..b523a78 100644 --- a/src/Language/Fiddle/Compiler.hs +++ b/src/Language/Fiddle/Compiler.hs @@ -1,6 +1,9 @@ module Language.Fiddle.Compiler where +import Control.Monad (when) +import Control.Monad.RWS (RWS, RWST, evalRWS, mapRWS, runRWS) import Control.Monad.State +import Control.Monad.Trans.Maybe import Control.Monad.Writer import Data.Default import Language.Fiddle.Ast @@ -12,65 +15,39 @@ data Level = Error | Warning | Info data Diagnostic = Diagnostic Level String SourceSpan -- Compilation monad. Has diagnostics. Optionally produces a value. -newtype Compile s a = Compile (s -> (s, [Diagnostic], Maybe a)) +-- newtype Compile s a = Compile (s -> (s, [Diagnostic], Maybe a)) -instance Functor (Compile s) where - fmap fn (Compile cfn) = Compile $ \s -> - let (s', d', ma) = cfn s in (s, d', fmap fn ma) +newtype Compile s a = Compile (MaybeT (RWS () [Diagnostic] s) a) + deriving (Functor, Applicative, Monad) -instance Applicative (Compile s) where - (<*>) mfn ma = do - fn <- mfn - fn <$> ma - - pure = return - -instance Monad (Compile s) where - return a = Compile (,[],Just a) - - -- m a -> (a -> m b) -> m b - (>>=) (Compile cfn) fn = Compile $ \s -> - let (s', diags, ma) = cfn s - in case ma of - Nothing -> (s', diags, Nothing) - Just a -> - let (Compile cfn') = fn a - (s'', diags', mb) = cfn' s' - in (s'', diags ++ diags', mb) +compilationFailure :: Compile s a +compilationFailure = Compile $ MaybeT (return Nothing) instance MonadWriter [Diagnostic] (Compile s) where - tell diag = Compile (,diag,Just ()) - - listen (Compile fn) = Compile $ \s -> - let (s', diags, ma) = fn s in (s', diags, (,diags) <$> ma) - - -- Not really "correctly" implemented, but I suspect this function will not be - -- used very much. - pass (Compile fn) = Compile $ \s -> - let (s', diags, mafn) = fn s - in case mafn of - Just (a, fn) -> (s', fn diags, Just a) - Nothing -> (s', diags, Nothing) + tell = Compile . tell + listen (Compile fn) = Compile $ listen fn + pass (Compile fn) = Compile $ pass fn instance MonadState s (Compile s) where - get = Compile $ \s -> (s, [], Just s) - - put s = Compile $ const (s, [], Just ()) - -hoistMaybe :: Maybe a -> Compile s a -hoistMaybe ma = Compile (,[],ma) + get = Compile get + put s = Compile $ put s + state fn = Compile $ state fn -- Runs a sub-compilation routine with the given state, but discards the -- resulting state in favor of the original state. -subCompile :: s' -> Compile s' a -> Compile s a -subCompile s' (Compile fn) = Compile $ \s -> - let (_, diags, ma) = fn s' in (s, diags, ma) +subCompile :: s' -> Compile s' a -> Compile s (s', a) +subCompile s' (Compile mtrws) = Compile $ do + let (a, s, w) = runRWS (runMaybeT mtrws) () s' + tell w + MaybeT $ return $ fmap (s,) a + +-- mapMaybeT (mapRWS (\(a, _, w) -> (a, s', w))) mtrws -- Saves the state, runs the routine, then restores the state. pushState :: Compile s a -> Compile s a pushState cp = do s <- get - subCompile s cp + snd <$> subCompile s cp -- Runs a compilation routine. It produces diagnostics and maybe a result. -- Generally if the diagnostics contain an error, the result will be Nothing, @@ -80,12 +57,15 @@ pushState cp = do -- from returning something even if the diagnostics contain errors, but it -- generally wouldn't make much sense for this to be the case. compile :: Compile s a -> s -> ([Diagnostic], Maybe a) -compile (Compile fn) initState = - let (_, d, ma) = fn initState in (d, ma) +compile (Compile fn) initState = do + let (a, _, w) = runRWS (runMaybeT fn) () initState in (w, a) compile_ :: (Default s) => Compile s a -> ([Diagnostic], Maybe a) compile_ c = compile c def +hoistMaybe :: Maybe a -> Compile s a +hoistMaybe = Compile . MaybeT . return + newtype DiagnosticFormat = DiagnosticFormat (Diagnostic -> String) coloredFormat :: DiagnosticFormat @@ -117,3 +97,9 @@ diagnosticToString (DiagnosticFormat f) = f printDiagnostic :: Diagnostic -> IO () printDiagnostic d = putStrLn (diagnosticToString coloredFormat d) + +fromMayberOrFail :: SourceSpan -> String -> Maybe a -> Compile s a +fromMayberOrFail sourceSpan err Nothing = do + tell [Diagnostic Error err sourceSpan] + compilationFailure +fromMayberOrFail _ _ (Just a) = return a 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') + ) diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs index 21cfa68..b17954f 100644 --- a/src/Language/Fiddle/GenericTree.hs +++ b/src/Language/Fiddle/GenericTree.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -15,29 +16,58 @@ import Data.Aeson.Encoding (text) import Data.Aeson.Types as Aeson import qualified Data.Foldable import Data.Functor.Classes (Show1, liftShowsPrec) +import Data.Kind (Type) import Data.Proxy import qualified Data.Text +import Data.Typeable import qualified Data.Vector import GHC.Generics import GHC.TypeLits (KnownSymbol, symbolVal) import Language.Fiddle.Ast +import Language.Fiddle.Types +import Text.Parsec.Pos import Text.Printf (printf) +type Context stage = (Show (NumberType stage), Typeable stage) + data GenericSyntaxTree f a where {- GenericSyntaxtTree with a name and children. -} SyntaxTreeObject :: + forall a f tree. + (Typeable tree) => String -> [GenericSyntaxTree f a] -> a -> + tree -> 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 +instance ToJSON Comment where + toJSON (NormalComment str) = object ["normal" .= str] + toJSON (DocComment str) = object ["doc" .= str] + +instance (ToJSON a) => ToJSON (Commented a) where + toJSON (Commented comment a) = + object ["comment" .= comment, "annot" .= a] + +instance ToJSON SourceSpan where + toJSON (SourceSpan start end) = + object ["start" .= toJSON start, "end" .= toJSON end] + +instance ToJSON SourcePos where + toJSON sourcePos = + object + [ "name" .= sourceName sourcePos, + "row" .= sourceLine sourcePos, + "col" .= sourceColumn sourcePos + ] + +instance (Foldable f, ToJSON a) => ToJSON (GenericSyntaxTree f a) where toJSON = \case - (SyntaxTreeObject typ membs a) -> - object ["_type" .= typ, "_members" .= membs, "_annot" .= show a] + (SyntaxTreeObject typ membs a t) -> + object ["_type" .= show (typeOf t), "_con" .= typ, "_members" .= membs, "_annot" .= a] (SyntaxTreeList l) -> Array $ Data.Vector.fromList $ map toJSON l (SyntaxTreeDeferred fdef) -> @@ -45,8 +75,8 @@ instance (Foldable f, Show a) => ToJSON (GenericSyntaxTree f a) where (SyntaxTreeValue s) -> String (Data.Text.pack s) toEncoding = \case - (SyntaxTreeObject typ membs a) -> - pairs $ "_type" .= typ <> "_members" .= membs <> "_annot" .= show a + (SyntaxTreeObject typ membs a t) -> + pairs $ "_type" .= show (typeOf t) <> "_con" .= typ <> "_members" .= membs <> "_annot" .= a (SyntaxTreeList l) -> foldable $ map toJSON l (SyntaxTreeDeferred fdef) -> @@ -62,16 +92,18 @@ class ToGenericSyntaxTreeValue v where instance ToGenericSyntaxTreeValue Data.Text.Text where toGenericSyntaxTreeValue = SyntaxTreeValue . Data.Text.unpack -class ToGenericSyntaxTree (t :: (* -> *) -> * -> *) where - toGenericSyntaxTree :: (Traversable f) => t f a -> GenericSyntaxTree f a +type GenericContext t f a = (Traversable f, ToGenericSyntaxTree t, Typeable t, Typeable f, Typeable a) + +class ToGenericSyntaxTree (t :: (Type -> Type) -> Type -> Type) where + toGenericSyntaxTree :: (Traversable f, Typeable f, Typeable t, Typeable a) => t f a -> GenericSyntaxTree f a default toGenericSyntaxTree :: - (Generic (t f a), (GToGenericSyntaxTree (Rep (t f a)) f a), (Traversable f)) => + (GenericContext t f a, Generic (t f a), (GToGenericSyntaxTree (Rep (t f a)) f a)) => t f a -> GenericSyntaxTree f a - toGenericSyntaxTree = gToGenericSyntaxTree . from + toGenericSyntaxTree t = gToGenericSyntaxTree t (from t) class GToGenericSyntaxTree r f a where - gToGenericSyntaxTree :: r x -> GenericSyntaxTree f a + gToGenericSyntaxTree :: (Typeable t) => t -> r x -> GenericSyntaxTree f a class GToMemberList r f a where gToMemberList :: Int -> r x -> [GenericSyntaxTree f a] @@ -80,16 +112,16 @@ instance (ToGenericSyntaxTreeValue v) => GToMemberList (Rec0 v) f a where gToMemberList _ = (: []) . toGenericSyntaxTreeValue . unK1 instance - (Traversable f, ToGenericSyntaxTree r) => + (GenericContext r f a) => GToGenericSyntaxTree (Rec0 (f (r f a))) f a where - gToGenericSyntaxTree k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1) + gToGenericSyntaxTree _ k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1) instance - (Traversable f, Traversable f1, ToGenericSyntaxTree r) => + (GenericContext r f a, Traversable f1) => GToGenericSyntaxTree (Rec0 (f1 (r f a))) f a where - gToGenericSyntaxTree k1 = + gToGenericSyntaxTree _ k1 = SyntaxTreeList (Data.Foldable.toList $ toGenericSyntaxTree <$> unK1 k1) instance @@ -100,11 +132,11 @@ instance where l1 = gToMemberList n l -instance (ToGenericSyntaxTree t, Traversable f) => GToMemberList (Rec0 (t f a)) f a where +instance (GenericContext t f a) => GToMemberList (Rec0 (t f a)) f a where gToMemberList _ a = [toGenericSyntaxTree (unK1 a)] instance - (ToGenericSyntaxTree t, Traversable f, Foldable l) => + (GenericContext t f a, Foldable l) => GToMemberList (Rec0 (l (t f a))) f a where gToMemberList _ as = toGenericSyntaxTree <$> Data.Foldable.toList (unK1 as) @@ -112,18 +144,18 @@ instance instance GToMemberList (Rec0 a) f a where gToMemberList _ _ = [] -instance GToMemberList r f a => GToMemberList (M1 i c r) f a where +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 (GenericContext r f a) => 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) + gToGenericSyntaxTree t c = + SyntaxTreeObject (symbolVal (nameProxy c)) (gToMemberList 0 (unM1 c)) (gannot c) t where nameProxy :: C1 ('MetaCons name _f _b) r x -> Proxy name nameProxy _ = Proxy @@ -132,22 +164,22 @@ 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 + gToGenericSyntaxTree t (L1 l) = gToGenericSyntaxTree t l + gToGenericSyntaxTree t (R1 r) = gToGenericSyntaxTree t r instance (GToGenericSyntaxTree r f a) => (GToGenericSyntaxTree (M1 i c r) f a) where - gToGenericSyntaxTree (M1 r) = gToGenericSyntaxTree r + gToGenericSyntaxTree t (M1 r) = gToGenericSyntaxTree t r -- deriving instance (ToGenericSyntaxTree (Test stage)) -deriving instance (ToGenericSyntaxTree (Identifier stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (Identifier stage)) -deriving instance (ToGenericSyntaxTree (FiddleUnit stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleUnit stage)) -deriving instance (ToGenericSyntaxTree (FiddleDecl stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleDecl stage)) -instance ToGenericSyntaxTree (ObjType stage) where - toGenericSyntaxTree = \case +instance (Context stage) => ToGenericSyntaxTree (ObjType stage) where + toGenericSyntaxTree t = case t of (AnonymousObjType body annot) -> SyntaxTreeDeferred $ fmap @@ -156,6 +188,7 @@ instance ToGenericSyntaxTree (ObjType stage) where "AnonymousObjType" [toGenericSyntaxTree body'] annot + body' ) body (ArrayObjType arr expr annot) -> @@ -163,49 +196,63 @@ instance ToGenericSyntaxTree (ObjType stage) where "ArrayObjType" [toGenericSyntaxTree arr, toGenericSyntaxTree expr] annot + t (ReferencedObjType ident a) -> - SyntaxTreeObject "ReferencedObjType" [toGenericSyntaxTree ident] a + SyntaxTreeObject "ReferencedObjType" [toGenericSyntaxTree ident] a t -deriving instance (ToGenericSyntaxTree (ObjTypeBody stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (ObjTypeBody stage)) -deriving instance (ToGenericSyntaxTree (ObjTypeDecl stage)) +instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage)) where + toGenericSyntaxTree t = case t of + (AssertPosStatement expr a) -> + SyntaxTreeObject "AssertPosStatement" [toGenericSyntaxTree expr] a t + (RegisterDecl mMod mIdent expr mBody a) -> + SyntaxTreeObject + "RegisterDecl" + ( Data.Foldable.toList (toGenericSyntaxTree <$> mMod) + ++ Data.Foldable.toList (toGenericSyntaxTree <$> mIdent) + ++ [toGenericSyntaxTree expr] + ++ Data.Foldable.toList (toGenericSyntaxTree <$> mBody) + ) + a + t deriving instance (ToGenericSyntaxTreeValue ModifierKeyword) -deriving instance (ToGenericSyntaxTree (Modifier stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (Modifier stage)) -deriving instance (ToGenericSyntaxTree (DeferredRegisterBody stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (DeferredRegisterBody stage)) -deriving instance (ToGenericSyntaxTree (RegisterBody stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (RegisterBody stage)) -deriving instance (ToGenericSyntaxTree (RegisterBitsDecl stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (RegisterBitsDecl stage)) -instance ToGenericSyntaxTree (RegisterBitsTypeRef stage) where - toGenericSyntaxTree = \case +instance (Context stage) => ToGenericSyntaxTree (RegisterBitsTypeRef stage) where + toGenericSyntaxTree t = case t of (RegisterBitsArray ref exp a) -> SyntaxTreeObject "RegisterBitsArray" [toGenericSyntaxTree ref, toGenericSyntaxTree exp] a + t (RegisterBitsReference i a) -> - SyntaxTreeObject "RegisterBitsReference" [toGenericSyntaxTree i] a + SyntaxTreeObject "RegisterBitsReference" [toGenericSyntaxTree i] a t (RegisterBitsAnonymousType t a) -> - SyntaxTreeObject "RegisterBitsAnonymousType " [toGenericSyntaxTree t] a + SyntaxTreeObject "RegisterBitsAnonymousType " [toGenericSyntaxTree t] a t (RegisterBitsJustBits t a) -> - SyntaxTreeObject "RegisterBitsJustBits " [toGenericSyntaxTree t] a + SyntaxTreeObject "RegisterBitsJustBits " [toGenericSyntaxTree t] a t -deriving instance (ToGenericSyntaxTree (AnonymousBitsType stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (AnonymousBitsType stage)) -deriving instance (ToGenericSyntaxTree (BitType stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (BitType stage)) -deriving instance (ToGenericSyntaxTree (EnumBody stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (EnumBody stage)) -deriving instance (ToGenericSyntaxTree (EnumConstantDecl stage)) +deriving instance (Context stage) => (ToGenericSyntaxTree (EnumConstantDecl stage)) -deriving instance (ToGenericSyntaxTree (PackageBody stage)) +deriving instance (Context stage) => (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 +instance (Context stage) => (ToGenericSyntaxTree (Expression stage)) where + toGenericSyntaxTree tr = case tr of + LitNum t a -> SyntaxTreeObject "LitNum" [SyntaxTreeValue (show t)] a tr + Var t a -> SyntaxTreeObject "LitNum" [toGenericSyntaxTree t] a tr diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index c9c3c86..dc479d1 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -7,6 +7,7 @@ module Language.Fiddle.Parser ) where +import Data.Kind (Type) import Data.Functor.Identity import Data.Text (Text) import qualified Data.Text @@ -26,7 +27,7 @@ type P = ParsecT S () Identity type A = Commented SourceSpan -type Pa (a :: Stage -> (* -> *) -> * -> *) = P (a 'Stage1 F (Commented SourceSpan)) +type Pa (a :: Stage -> (Type -> Type) -> Type -> Type) = P (a 'Stage1 F (Commented SourceSpan)) comment :: P Comment comment = diff --git a/src/Language/Fiddle/Types.hs b/src/Language/Fiddle/Types.hs index 507b8cf..0f3b5b1 100644 --- a/src/Language/Fiddle/Types.hs +++ b/src/Language/Fiddle/Types.hs @@ -12,5 +12,5 @@ data SourceSpan = SourceSpan } deriving (Eq, Ord, Show) -data Commented a = Commented ![Comment] !a +data Commented a = Commented { comments :: ![Comment], unCommented :: !a } deriving (Show) diff --git a/src/Main.hs b/src/Main.hs index 92e9a1d..9330df5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,6 +9,7 @@ import GHC.IO.Exception (ExitCode (ExitFailure)) import Language.Fiddle.Ast import Language.Fiddle.Compiler (coloredFormat, compile_, printDiagnostic) import Language.Fiddle.Compiler.Stage0 +import Language.Fiddle.Compiler.Stage1 import Language.Fiddle.GenericTree (ToGenericSyntaxTree (toGenericSyntaxTree)) import qualified Language.Fiddle.Parser import qualified Language.Fiddle.Tokenizer @@ -22,11 +23,10 @@ main = do case argv of [filePath] -> do text <- Data.Text.IO.readFile filePath - let (diags, ma) = compile_ $ toStage1 =<< toStage0 filePath text + let (diags, ma) = compile_ $ toStage2 =<< toStage1 =<< toStage0 filePath text forM_ diags printDiagnostic case ma of Just ast -> do - putStrLn "\x1b[1;32mCompilation Succeeded:\x1b[0m" putStrLn $ BL.unpack $ encode $ toGenericSyntaxTree ast Nothing -> do putStrLn "\x1b[1;31mCompilation Failed\x1b[0m" @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-18.15 +resolver: lts-22.33 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/vim/syntax/fiddle.vim b/vim/syntax/fiddle.vim index 01e9d04..22341a5 100644 --- a/vim/syntax/fiddle.vim +++ b/vim/syntax/fiddle.vim @@ -13,7 +13,7 @@ syn match FiddleIdent +[A-Za-z0-9_]\++ contained syn match FiddleComment +\/\/.*$+ syn region FiddleDocComment start=+/\*\*+ end=+*/+ -syn match FiddleNumber +[0-9_]\+\([xb]\)\@!\|0x[0-9A-Fa-f_]\+\|0b[01]\++ +syn match FiddleNumber +[0-9_]\+\([xb]\)\@!\|0x[0-9A-Fa-f][0-9A-Fa-f_]*\|0b[01]\++ hi! link FiddleContainedType Type hi! link FiddleModifier StorageClass |