diff options
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast.hs | 43 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler.hs | 3 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage0.hs | 2 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage1.hs | 49 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage2.hs | 286 | ||||
| -rw-r--r-- | src/Language/Fiddle/GenericTree.hs | 8 | ||||
| -rw-r--r-- | src/Language/Fiddle/Parser.hs | 5 | ||||
| -rw-r--r-- | src/Main.hs | 21 |
9 files changed, 350 insertions, 68 deletions
diff --git a/package.yaml b/package.yaml index 2f78def..f2394a7 100644 --- a/package.yaml +++ b/package.yaml @@ -34,3 +34,4 @@ dependencies: - bytestring - data-default - transformers + - containers diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs index 277ab24..d440a44 100644 --- a/src/Language/Fiddle/Ast.hs +++ b/src/Language/Fiddle/Ast.hs @@ -5,6 +5,7 @@ {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} module Language.Fiddle.Ast where @@ -33,14 +34,14 @@ data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where deriving (Generic, Annotated, Alter, Typeable) -- Just an identifier. -data Identifier stage f a = Identifier !Text a +data Identifier f a = Identifier !Text a deriving (Generic, Annotated, Alter, Typeable) -- Expression. data Expression stage f a where -- Just a string. Parsing the number comes in stage2. LitNum :: NumberType stage -> a -> Expression stage f a - Var :: Identifier stage f a -> a -> Expression stage f a + Var :: Identifier f a -> a -> Expression stage f a -- Top-level declarations. data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where @@ -49,37 +50,37 @@ data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where - option <ident> <ident>; -} OptionDecl :: - Identifier stage f a -> - Identifier stage f a -> + Identifier f a -> + Identifier f a -> a -> FiddleDecl stage f a {- Package Statement. Package Name, Package body -} PackageDecl :: - Identifier stage f a -> + Identifier f a -> f (PackageBody stage f a) -> a -> FiddleDecl stage f a {- location <identifier> = <expr>. -} LocationDecl :: - Identifier stage f a -> + Identifier f a -> Expression stage f a -> a -> FiddleDecl stage f a {- bits <identifier> : <type> -} BitsDecl :: - Identifier stage f a -> + Identifier f a -> BitType stage f a -> a -> FiddleDecl stage f a {- objtype <identifier> : <type> -} ObjTypeDecl :: - Identifier stage f a -> + Identifier f a -> f (ObjTypeBody stage f a) -> a -> FiddleDecl stage f a {- object <ident> at <expr> : <type> -} ObjectDecl :: - Identifier stage f a -> + Identifier f a -> Expression stage f a -> ObjType stage f a -> a -> @@ -98,28 +99,30 @@ data ObjType stage f a where -- <type>[<expr>] 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 + ReferencedObjType :: Identifier f a -> a -> ObjType stage f a deriving (Typeable) +type StageLessThan stage (n :: Natural) = (CmpNat (StageNumber stage) n ~ LT) + data ObjTypeDecl stage f a where {- assert_pos(<expr>) -} AssertPosStatement :: - (CmpNat (StageNumber stage) 3 ~ LT) => + (StageLessThan stage 3) => Expression stage f a -> a -> ObjTypeDecl stage f a {- reg <ident>(<expr>) : <regtype> -} RegisterDecl :: - Maybe (Modifier stage f a) -> - Maybe (Identifier stage f a) -> + Maybe (Modifier f a) -> + Maybe (Identifier f a) -> Expression stage f a -> Maybe (RegisterBody stage f a) -> a -> ObjTypeDecl stage f a deriving (Typeable) -data Modifier stage f a where - ModifierKeyword :: ModifierKeyword -> a -> Modifier stage f a +data Modifier f a where + ModifierKeyword :: ModifierKeyword -> a -> Modifier f a deriving (Generic, Annotated, Alter, Typeable) data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read, Typeable) @@ -140,8 +143,8 @@ data RegisterBitsDecl stage f a where ReservedBits :: Expression stage f a -> a -> RegisterBitsDecl stage f a -- <modifer> <ident> : <type> DefinedBits :: - Maybe (Modifier stage f a) -> - Identifier stage f a -> + Maybe (Modifier f a) -> + Identifier f a -> RegisterBitsTypeRef stage f a -> a -> RegisterBitsDecl stage f a @@ -155,7 +158,7 @@ data RegisterBitsTypeRef stage f a where a -> RegisterBitsTypeRef stage f a {- Reference to a type. -} - RegisterBitsReference :: Identifier stage f a -> a -> RegisterBitsTypeRef stage f a + RegisterBitsReference :: Identifier f a -> a -> RegisterBitsTypeRef stage f a {- enum(<expr>) { <body> } Anonymous types are only allowed in stage1. Stage2 should de-anonymize these type. -} @@ -258,7 +261,7 @@ data EnumBody (stage :: Stage) (f :: Type -> Type) a where data EnumConstantDecl stage f a where -- <ident> = <expr> - EnumConstantDecl :: Identifier stage 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 deriving (Generic, Annotated, Alter, Typeable) @@ -271,7 +274,7 @@ data PackageBody (stage :: Stage) (f :: Type -> Type) a where -- instance Alter (Modifier stage) where -- alter _ fn (ModifierKeyword m a) = ModifierKeyword m (fn a) -- --- instance Alter (Identifier stage) where +-- instance Alter (Identifier) where -- alter _ fn (Identifier i a) = Identifier i $ fn a -- -- instance Alter (Expression stage) where diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs index b523a78..768c569 100644 --- a/src/Language/Fiddle/Compiler.hs +++ b/src/Language/Fiddle/Compiler.hs @@ -9,6 +9,7 @@ import Data.Default import Language.Fiddle.Ast import Language.Fiddle.Types import Text.Parsec (SourcePos, sourceColumn, sourceLine, sourceName) +import System.IO (hPutStrLn, stderr) data Level = Error | Warning | Info @@ -96,7 +97,7 @@ diagnosticToString (DiagnosticFormat f) = f printDiagnostic :: Diagnostic -> IO () printDiagnostic d = - putStrLn (diagnosticToString coloredFormat d) + hPutStrLn stderr (diagnosticToString coloredFormat d) fromMayberOrFail :: SourceSpan -> String -> Maybe a -> Compile s a fromMayberOrFail sourceSpan err Nothing = do diff --git a/src/Language/Fiddle/Compiler/Stage0.hs b/src/Language/Fiddle/Compiler/Stage0.hs index 77c396e..fbc554b 100644 --- a/src/Language/Fiddle/Compiler/Stage0.hs +++ b/src/Language/Fiddle/Compiler/Stage0.hs @@ -55,7 +55,7 @@ parseErrorToDiagnostic pe = "unknown" "expecting" "unexpected" - "end of body or input (maybe a missing semicolon?)" + "end of body or input (maybe a missing semicolon or comma?)" (errorMessages pe) ) (SourceSpan (errorPos pe) (errorPos pe)) diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs index 7a048fa..3a97757 100644 --- a/src/Language/Fiddle/Compiler/Stage1.hs +++ b/src/Language/Fiddle/Compiler/Stage1.hs @@ -41,18 +41,9 @@ data Stage2CompilerState a -- Anonymous enum bodies that need to be re-linked ![(Linkage, AnonymousBitsType Stage2 I a)] -class EasyStage2 t where - toS2 :: t s1 I a -> t s2 I a - -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 -> ObjTypeBody Stage2 I a -> M a (Identifier I a) internObjType path body = let str = Text.pack $ joinPath path in do @@ -60,7 +51,7 @@ internObjType path body = 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 Stage2 I a -> M a (Identifier I a) internAnonymousBitsType path anonymousBitsType = let str = Text.pack $ joinPath path in do @@ -68,12 +59,6 @@ internAnonymousBitsType path anonymousBitsType = 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 Annot -> Compile () (FiddleUnit Stage2 I Annot) @@ -106,21 +91,21 @@ reconfigureFiddleDecls p decls = do resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) = BitsDecl (Identifier linkage a) (EnumBitType expr body a) a -pushId :: Identifier stage f a -> Path -> Path +pushId :: Identifier 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 + (OptionDecl i1 i2 a) -> return $ OptionDecl i1 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 + (PackageDecl i . Identity <$> packageBodyToStage2 (pushId i path) body) <*> pure a + (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 (ObjectDecl i expr typ a) -> - ObjectDecl (toS2 i) <$> toStage2Expr expr <*> objectTypeToStage2 (pushId i path) typ <*> pure a + ObjectDecl 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 @@ -134,7 +119,7 @@ enumBodyToStage2 path = \case 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 + EnumConstantDecl i e a -> EnumConstantDecl 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) @@ -146,8 +131,8 @@ objTypeDeclToStage2 path = \case (RegisterDecl maybeModifier maybeIdentifier expression maybeBody annot) -> let path' = maybe path (`pushId` path) maybeIdentifier in RegisterDecl - (fmap toS2 maybeModifier) - (fmap toS2 maybeIdentifier) + maybeModifier + maybeIdentifier <$> toStage2Expr expression <*> mapM (registerBodyToStage2 path') maybeBody <*> pure annot @@ -167,8 +152,8 @@ registerBitsDeclToStage2 path = \case DefinedBits maybeModifier identifier registerBitsTyperef annot -> let path' = pushId identifier path in ( DefinedBits - (fmap toS2 maybeModifier) - (toS2 identifier) + maybeModifier + identifier <$> registerBitsTypeRefToStage2 path' registerBitsTyperef <*> pure annot ) @@ -180,7 +165,7 @@ registerBitsTypeRefToStage2 path = \case <$> registerBitsTypeRefToStage2 path typeref <*> toStage2Expr expr <*> pure annot - RegisterBitsReference ident annot -> return (RegisterBitsReference (toS2 ident) annot) + RegisterBitsReference ident annot -> return (RegisterBitsReference ident annot) RegisterBitsJustBits expr annot -> RegisterBitsJustBits <$> toStage2Expr expr <*> pure annot RegisterBitsAnonymousType anonType annot -> do ident <- internAnonymousBitsType path =<< anonymousBitsTypeToStage2 path anonType @@ -200,7 +185,7 @@ objectTypeToStage2 path = \case body' <- objTypeBodyToStage2 path body identifier <- internObjType path body' return (ReferencedObjType identifier annot) - (ReferencedObjType ident annot) -> return $ ReferencedObjType (toS2 ident) annot + (ReferencedObjType ident annot) -> return $ ReferencedObjType ident annot (ArrayObjType objType expr a) -> ArrayObjType <$> objectTypeToStage2 path objType <*> toStage2Expr expr <*> pure a @@ -210,7 +195,7 @@ packageBodyToStage2 p (PackageBody decls a) = toStage2Expr :: Expression Stage1 I Annot -> M Annot (Expression Stage2 I Annot) toStage2Expr = \case - (Var i a) -> return $ Var (toS2 i) a + (Var i a) -> return $ Var i a (LitNum t a) -> LitNum <$> parseNum (unCommented a) t <*> pure a parseNum :: SourceSpan -> Text -> M a Integer diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs new file mode 100644 index 0000000..baa61e3 --- /dev/null +++ b/src/Language/Fiddle/Compiler/Stage2.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- Stage3 doesn't change much from Stage2. Stage3 primarily removes the assert +-- statements and checks that they are consistent with the calculations. +module Language.Fiddle.Compiler.Stage2 where + +import Control.Monad (forM_, unless, when) +import Control.Monad.RWS (MonadWriter (tell), gets, modify') +import Data.Foldable (foldlM) +import Data.Functor.Identity +import qualified Data.IntMap as IntMap +import Data.Kind (Type) +import Data.List (intercalate) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Word +import Language.Fiddle.Ast +import Language.Fiddle.Compiler +import Language.Fiddle.Types (Commented (unCommented), SourceSpan) +import Text.Printf (printf) +import Prelude hiding (unzip) + +type I = Identity + +type Annot = Commented SourceSpan + +type SizeBits = Word32 + +type SizeBytes = Word32 + +data Stage3State = Stage3State + { typeSizes :: Map String SizeBits, + objectSizes :: Map String SizeBytes, + cursorBytes :: Word32, + cursorBits :: Word32 + } + +addTypeSize :: Identifier f a -> SizeBits -> Compile Stage3State () +addTypeSize (Identifier s _) size = do + modify' $ + \stage3State -> + stage3State {typeSizes = Map.insert (Text.unpack s) size (typeSizes stage3State)} + +lookupTypeSize :: Identifier I Annot -> Compile Stage3State SizeBits +lookupTypeSize (Identifier s a) = do + mSize <- gets $ Map.lookup (Text.unpack s) . typeSizes + case mSize of + Just sz -> return sz + Nothing -> do + tell + [ Diagnostic + Error + (printf "%s is not declared" s) + (unCommented a) + ] + compilationFailure + +expressionToStage3 :: Expression Stage2 f Annot -> Expression Stage3 f Annot +expressionToStage3 = \case + LitNum n a -> LitNum n a + Var i a -> Var i a + +emptyState = Stage3State mempty mempty 0 0 + +toStage3 :: FiddleUnit Stage2 I Annot -> Compile () (FiddleUnit Stage3 I Annot) +toStage3 (FiddleUnit decls a) = + snd + <$> subCompile + emptyState + ( FiddleUnit <$> mapM fiddleDeclToStage3 decls <*> pure a + ) + +exprToSize :: + (NumberType stage ~ Integer) => + Expression stage I Annot -> + Compile s Integer +exprToSize (LitNum num _) = return num +exprToSize e = do + tell [Diagnostic Error "Variables not allowed" (unCommented $ annot e)] + compilationFailure + +getTypeSize :: BitType Stage2 I Annot -> Compile s SizeBits +getTypeSize (RawBits expr _) = fromIntegral <$> exprToSize expr +getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do + declaredSize <- fromIntegral <$> exprToSize expr + + -- If the declared size is less than or equal to 4, we'll enforce that the + -- enum is packed. This is to make sure the user has covered all bases. + when (declaredSize <= 4) $ do + imap <- + foldlM + ( \imap enumConst -> do + number <- case enumConst of + EnumConstantDecl _ expr _ -> exprToSize expr + EnumConstantReserved expr _ -> exprToSize expr + + when (number >= 2 ^ declaredSize) $ + tell + [ Diagnostic + Error + (printf "Enum constant too large. Max allowed %d\n" ((2 :: Int) ^ declaredSize)) + (unCommented (annot enumConst)) + ] + + return $ IntMap.insert (fromIntegral number) True imap + ) + IntMap.empty + constants + let missing = filter (not . (`IntMap.member` imap)) [0 .. 2 ^ declaredSize - 1] + unless (null missing) $ + tell + [ Diagnostic + Warning + ( printf + "Missing enum constants %s. Please fully pack a small enum.\ + \ Use 'reserved' if needed." + (intercalate ", " (map show missing)) + ) + (unCommented ann) + ] + + return declaredSize + +fiddleDeclToStage3 :: FiddleDecl Stage2 I Annot -> Compile Stage3State (FiddleDecl Stage3 I Annot) +fiddleDeclToStage3 = \case + OptionDecl i1 i2 a -> return $ OptionDecl i1 i2 a + PackageDecl id body a -> PackageDecl id <$> mapM packageBodyToStage3 body <*> pure a + LocationDecl id expr a -> return $ LocationDecl id (expressionToStage3 expr) a + BitsDecl id typ a -> do + typeSize <- getTypeSize typ + addTypeSize id typeSize + BitsDecl id <$> bitTypeToStage3 typ <*> pure a + ObjTypeDecl ident body a -> + ObjTypeDecl ident <$> mapM objTypeBodyToStage3 body <*> pure a + ObjectDecl ident expr typ a -> + ObjectDecl ident (expressionToStage3 expr) <$> objTypeToStage3 typ <*> pure a + +objTypeToStage3 :: ObjType Stage2 I Annot -> Compile Stage3State (ObjType Stage3 I Annot) +objTypeToStage3 = \case + ArrayObjType objtype expr a -> + ArrayObjType + <$> objTypeToStage3 objtype + <*> pure (expressionToStage3 expr) + <*> pure a + ReferencedObjType ident a -> return $ ReferencedObjType ident a + +registerBodyToStage3 :: + RegisterBody Stage2 I Annot -> + Compile Stage3State (RegisterBody Stage3 I Annot, Word32) +registerBodyToStage3 (RegisterBody (Identity deferredRegisterBody) a') = + case deferredRegisterBody of + DeferredRegisterBody decls a -> do + (cur, returned) <- + foldlM + ( \(cursor, returned) decl -> + case decl of + ReservedBits expr a -> do + size <- exprToSize expr + let s3 = ReservedBits (expressionToStage3 expr) a + return (cursor + fromIntegral size, s3 : returned) + DefinedBits modifier identifier typeref a -> do + (s3TypeRef, size) <- registerBitsTypeRefToStage3 typeref + return (cursor + size, DefinedBits modifier identifier s3TypeRef a : returned) + ) + (0, []) + decls + + return (RegisterBody (Identity (DeferredRegisterBody (reverse returned) a)) a', cur) + +registerBitsTypeRefToStage3 :: + RegisterBitsTypeRef Stage2 I Annot -> + Compile Stage3State (RegisterBitsTypeRef Stage3 I Annot, Word32) +registerBitsTypeRefToStage3 = \case + RegisterBitsArray ref expr a -> do + (ref', size) <- registerBitsTypeRefToStage3 ref + multiplier <- exprToSize expr + return + ( RegisterBitsArray ref' (expressionToStage3 expr) a, + size * fromIntegral multiplier + ) + RegisterBitsReference ident a -> + (RegisterBitsReference ident a,) <$> lookupTypeSize ident + RegisterBitsJustBits expr a -> + (RegisterBitsJustBits (expressionToStage3 expr) a,) + . fromIntegral + <$> exprToSize expr + +objTypeBodyToStage3 :: + ObjTypeBody Stage2 I Annot -> Compile Stage3State (ObjTypeBody Stage3 I Annot) +objTypeBodyToStage3 (ObjTypeBody decls a) = do + (cur, returned) <- + foldlM + ( \(cursor, returned) decl -> + case decl of + RegisterDecl mMod mIdent expr mBody a -> do + (s3RegisterBody, mCalculatedSize) <- + fUnzip <$> mapM registerBodyToStage3 mBody + + let s3 = + RegisterDecl + mMod + mIdent + (expressionToStage3 expr) + s3RegisterBody + a + + declaredSizeBits <- exprToSize expr + + when ((declaredSizeBits `mod` 8) /= 0) $ + tell + [ Diagnostic + Error + "Register size is not a multiple of 8. Please pad register size to align with 8. " + (unCommented a) + ] + + forM_ mCalculatedSize $ \(fromIntegral -> calculatedSize) -> + unless (calculatedSize == declaredSizeBits) $ + let helpful = + if calculatedSize < declaredSizeBits then + printf "\nPerhaps you should add 'reserved(%d)' to the end of your register declaration?" + (declaredSizeBits - calculatedSize) + else "" + in + + tell + [ Diagnostic + Error + ( printf + "Calculated size %d does not match declared size %d.%s" + calculatedSize + declaredSizeBits + helpful + ) + (unCommented a) + ] + + return (cursor + declaredSizeBits `div` 8, s3 : returned) + AssertPosStatement expr a -> do + declaredPos <- exprToSize expr + when (cursor /= declaredPos) $ do + tell + [ Diagnostic + Error + ( printf + "Position assertion failed. Asserted 0x%x, calculated 0x%x" + declaredPos + cursor + ) + (unCommented a) + ] + return (cursor, returned) + ) + (0 :: Integer, []) + decls + + return $ ObjTypeBody (reverse returned) a + where + fUnzip xs = (fst <$> xs, snd <$> xs) + pushApply :: Maybe (a, b) -> (Maybe a, Maybe b) + pushApply (Just (a, b)) = (Just a, Just b) + pushApply Nothing = (Nothing, Nothing) + +bitTypeToStage3 :: BitType Stage2 I Annot -> Compile Stage3State (BitType Stage3 I Annot) +bitTypeToStage3 (EnumBitType expr body a) = + EnumBitType (expressionToStage3 expr) + <$> mapM enumBodyToStage3 body + <*> pure a + +enumBodyToStage3 :: EnumBody Stage2 I Annot -> Compile Stage3State (EnumBody Stage3 I Annot) +enumBodyToStage3 (EnumBody constants a) = + EnumBody <$> mapM enumConstantDeclToStage3 constants <*> pure a + +enumConstantDeclToStage3 :: EnumConstantDecl Stage2 I Annot -> Compile Stage3State (EnumConstantDecl Stage3 I Annot) +enumConstantDeclToStage3 = \case + EnumConstantDecl ident expr a -> return $ EnumConstantDecl ident (expressionToStage3 expr) a + EnumConstantReserved expr a -> return $ EnumConstantReserved (expressionToStage3 expr) a + +packageBodyToStage3 :: PackageBody Stage2 I Annot -> Compile Stage3State (PackageBody Stage3 I Annot) +packageBodyToStage3 (PackageBody decls a) = + PackageBody <$> mapM fiddleDeclToStage3 decls <*> pure a diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs index b17954f..668c290 100644 --- a/src/Language/Fiddle/GenericTree.hs +++ b/src/Language/Fiddle/GenericTree.hs @@ -66,8 +66,8 @@ instance ToJSON SourcePos where instance (Foldable f, ToJSON a) => ToJSON (GenericSyntaxTree f a) where toJSON = \case - (SyntaxTreeObject typ membs a t) -> - object ["_type" .= show (typeOf t), "_con" .= typ, "_members" .= membs, "_annot" .= a] + (SyntaxTreeObject typ membs a _) -> + object ["_con" .= typ, "_members" .= membs, "_annot" .= a] (SyntaxTreeList l) -> Array $ Data.Vector.fromList $ map toJSON l (SyntaxTreeDeferred fdef) -> @@ -172,7 +172,7 @@ instance (GToGenericSyntaxTree r f a) => (GToGenericSyntaxTree (M1 i c r) f a) w -- deriving instance (ToGenericSyntaxTree (Test stage)) -deriving instance (Context stage) => (ToGenericSyntaxTree (Identifier stage)) +deriving instance (ToGenericSyntaxTree Identifier) deriving instance (Context stage) => (ToGenericSyntaxTree (FiddleUnit stage)) @@ -219,7 +219,7 @@ instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage)) where deriving instance (ToGenericSyntaxTreeValue ModifierKeyword) -deriving instance (Context stage) => (ToGenericSyntaxTree (Modifier stage)) +deriving instance (ToGenericSyntaxTree Modifier) deriving instance (Context stage) => (ToGenericSyntaxTree (DeferredRegisterBody stage)) diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index dc479d1..37ef34e 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -28,6 +28,7 @@ type P = ParsecT S () Identity type A = Commented SourceSpan type Pa (a :: Stage -> (Type -> Type) -> Type -> Type) = P (a 'Stage1 F (Commented SourceSpan)) +type PaS (a :: (Type -> Type) -> Type -> Type) = P (a F (Commented SourceSpan)) comment :: P Comment comment = @@ -139,7 +140,7 @@ objTypeDecl = <*> optionMaybe (tok TokColon *> registerBody) ) -modifier :: Pa Modifier +modifier :: PaS Modifier modifier = withMeta $ ModifierKeyword @@ -278,7 +279,7 @@ printNext = do traceM $ "NextToken: " ++ show t return () -ident :: Pa Identifier +ident :: PaS Identifier ident = withMeta $ token $ \case diff --git a/src/Main.hs b/src/Main.hs index 9330df5..f92d6c6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,11 +5,12 @@ import Control.Monad.Writer import Data.Aeson (encode) import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Text.IO -import GHC.IO.Exception (ExitCode (ExitFailure)) +import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess)) import Language.Fiddle.Ast import Language.Fiddle.Compiler (coloredFormat, compile_, printDiagnostic) import Language.Fiddle.Compiler.Stage0 import Language.Fiddle.Compiler.Stage1 +import Language.Fiddle.Compiler.Stage2 import Language.Fiddle.GenericTree (ToGenericSyntaxTree (toGenericSyntaxTree)) import qualified Language.Fiddle.Parser import qualified Language.Fiddle.Tokenizer @@ -23,14 +24,18 @@ main = do case argv of [filePath] -> do text <- Data.Text.IO.readFile filePath - let (diags, ma) = compile_ $ toStage2 =<< toStage1 =<< toStage0 filePath text + let (diags, ma) = compile_ $ toStage3 =<< toStage2 =<< toStage1 =<< toStage0 filePath text + ec <- + case ma of + Just ast -> do + putStrLn $ BL.unpack $ encode $ toGenericSyntaxTree ast + return ExitSuccess + Nothing -> do + putStrLn "\x1b[1;31mCompilation Failed\x1b[0m" + return (ExitFailure 1) + forM_ diags printDiagnostic - case ma of - Just ast -> do - putStrLn $ BL.unpack $ encode $ toGenericSyntaxTree ast - Nothing -> do - putStrLn "\x1b[1;31mCompilation Failed\x1b[0m" - exitWith (ExitFailure 1) + exitWith ec _ -> do putStrLn "Wrong Args" exitWith (ExitFailure 2) |