summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--goal.fiddle16
-rw-r--r--package.yaml3
-rw-r--r--src/Language/Fiddle/Ast/Internal/Instances.hs56
-rw-r--r--src/Language/Fiddle/Ast/Internal/SyntaxTree.hs10
-rw-r--r--src/Language/Fiddle/Compiler.hs34
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs134
-rw-r--r--src/Language/Fiddle/Compiler/Expansion.hs6
-rw-r--r--src/Language/Fiddle/Compiler/ImportResolution.hs163
-rw-r--r--src/Language/Fiddle/GenericTree.hs25
-rw-r--r--src/Language/Fiddle/Internal/Scopes.hs19
-rw-r--r--src/Language/Fiddle/Internal/UnitInterface.hs58
-rw-r--r--src/Language/Fiddle/Parser.hs24
-rw-r--r--src/Language/Fiddle/Types.hs46
-rw-r--r--src/Main.hs165
14 files changed, 615 insertions, 144 deletions
diff --git a/goal.fiddle b/goal.fiddle
index e6e6a28..c6707a5 100644
--- a/goal.fiddle
+++ b/goal.fiddle
@@ -3,15 +3,7 @@ option endian little;
option processor arm_cortex_m4;
option align 32;
-import "./types.fdl" (data_t);
-import "./stm32l432.fdl";
-
-package fiddle.lang {
- bits data_t : enum(1) {
- high = 0b1,
- low = 0b0,
- };
-};
+import "./types.fdl";
[[ cpp: namespace = "stm32l432::gpio" ]]
[[ rust: package = "Stm32l432.Gpio" ]]
@@ -22,8 +14,6 @@ package stm32l4.gpio {
location gpio_b_base = 0x4800_0400;
location gpio_c_base = 0x4800_0800;
- import "/usr/fiddle/import/other_import.fdl";
-
using stm32l432;
/**
@@ -128,7 +118,7 @@ package stm32l4.gpio {
union {
assert_pos(0x10);
ro reg (32) : struct {
- id_r : fiddle.lang.data_t[16];
+ id_r : common.data_t[16];
reserved(16);
};
@@ -155,7 +145,7 @@ package stm32l4.gpio {
assert_pos(0x14);
wo reg (32) : struct {
union {
- rw od_r : fiddle.lang.data_t[16];
+ rw od_r : common.data_t[16];
struct {
rw osp_v : (15);
diff --git a/package.yaml b/package.yaml
index 34c255e..217a741 100644
--- a/package.yaml
+++ b/package.yaml
@@ -44,3 +44,6 @@ dependencies:
- transformers
- containers
- optparse-applicative
+ - directory
+ - filepath
+ - zlib
diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs
index c9c3455..379c788 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances.hs
@@ -6,7 +6,7 @@ module Language.Fiddle.Ast.Internal.Instances
AdvanceStage (..),
CompilationStage (..),
Annotated (..),
- GAnnot (..)
+ GAnnot (..),
)
where
@@ -168,8 +168,13 @@ class
advanceStage s t = do
-- Modify the local state for this node before performing the transformation
s' <- modifyState t s
- -- Perform the generic transformation using 'gAdvanceStage'
- to <$> gAdvanceStage (Proxy :: Proxy stage) s' (from t)
+ specific <- customAdvanceStage t s
+
+ case specific of
+ Nothing ->
+ -- Perform the generic transformation using 'gAdvanceStage'
+ to <$> gAdvanceStage (Proxy :: Proxy stage) s' (from t)
+ Just ast -> return ast
-- | 'modifyState' allows for changes to the local state ('StageState') before
-- transforming the syntax tree node. This is called on each node during the
@@ -199,6 +204,40 @@ class
StageMonad stage (StageState stage) -- The modified local state
modifyState _ = return
+ -- \| An optional method that allows for partial customization of the
+ -- 'advanceStage' process. This method can be used to handle specific cases
+ -- in the input without requiring the implementer to redefine 'advanceStage'
+ -- for the entire structure. If this method returns 'Nothing', the default
+ -- generic implementation of 'advanceStage' is used.
+ --
+ -- This method is useful when only certain conditions or patterns in the
+ -- syntax tree need special handling during the stage transition. Implementers
+ -- can focus on those specific conditions and leave the remaining cases to the
+ -- generic traversal.
+ --
+ -- Parameters:
+ -- - 'StageState stage': The local state for the current stage.
+ -- - 'TreeType t stage': The syntax tree node at the current stage.
+ --
+ -- Returns:
+ -- - 'StageMonad stage (Maybe (t (StageAfter stage) (StageFunctor stage)
+ -- (StageAnnotation stage)))': A monadic computation that either returns
+ -- 'Just' the transformed tree node for the next stage, or 'Nothing' to
+ -- continue with the default generic implementation.
+ customAdvanceStage ::
+ TreeType t stage -> -- Syntax tree node at the current stage
+ StageState stage -> -- Local state for the current stage
+ StageMonad
+ stage
+ ( Maybe
+ ( t
+ (StageAfter stage) -- The next stage in the pipeline
+ (StageFunctor stage) -- Functor associated with the next stage
+ (StageAnnotation stage) -- Annotation type for the next stage
+ )
+ )
+ customAdvanceStage _ _ = return Nothing
+
-- | 'GAdvanceStage' is a helper type class that performs the transformation
-- of the generic representation of a syntax tree node. It is used by the
-- default implementation of 'advanceStage' to traverse and modify nodes
@@ -210,9 +249,14 @@ class GAdvanceStage (stage :: Stage) s m from to where
-- element.
class Annotated (t :: SynTree) where
annot :: t f a -> a
+ setAnnot :: (a -> a) -> t f a -> t f a
+
default annot :: (Generic (t f a), GAnnot a (Rep (t f a))) => t f a -> a
annot t = gannot (from t)
+ default setAnnot :: (Generic (t f a), GAnnot a (Rep (t f a))) => (a -> a) -> t f a -> t f a
+ setAnnot f t = to $ gsetAnnot f (from t)
+
-- Generic implementations of common typeclass for SyntaxTrees.
--
-- This is where we try to hide the pig behind the curtain.
@@ -299,19 +343,25 @@ instance
class GAnnot a r where
gannot :: r x -> a
+ gsetAnnot :: (a -> a) -> r x -> r x
instance GAnnot a (Rec0 a) where
gannot = unK1
+ gsetAnnot fn (K1 t) = K1 (fn t)
instance (GAnnot a r) => GAnnot a (l :*: r) where
gannot (_ :*: r) = gannot r
+ gsetAnnot fn (l :*: r) = l :*: gsetAnnot fn r
instance (GAnnot a r, GAnnot a l) => GAnnot a (l :+: r) where
gannot (R1 r) = gannot r
gannot (L1 l) = gannot l
+ gsetAnnot fn (R1 r) = R1 (gsetAnnot fn r)
+ gsetAnnot fn (L1 l) = L1 (gsetAnnot fn l)
instance (GAnnot a r) => GAnnot a (M1 i c r) where
gannot (M1 a) = gannot a
+ gsetAnnot fn (M1 a) = M1 (gsetAnnot fn a)
proxyOf :: t f a -> Proxy t
proxyOf _ = Proxy
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 706a178..8eb8c8e 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -10,6 +10,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
( -- Type Families
NumberType,
ImportInterface,
+ FiddleUnitInterface,
-- Witness Types
Witness (..),
WitnessType,
@@ -41,6 +42,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree
EnumBody (..),
EnumConstantDecl (..),
PackageBody (..),
+ TreeType (..),
-- Helper Functions
mapDirected,
mapDirectedM,
@@ -71,6 +73,8 @@ import Language.Fiddle.Ast.Internal.Kinds
import Language.Fiddle.Ast.Internal.Stage
import Language.Fiddle.Internal.UnitInterface (UnitInterface)
+type TreeType t stage = t stage (StageFunctor stage) (StageAnnotation stage)
+
type family FiddleUnitInterface (s :: Stage) :: Type where
FiddleUnitInterface s = If (s < Checked) () UnitInterface
@@ -233,11 +237,11 @@ undirected (Directed _ tfa _) = tfa
-- | The root of the parse tree, containing a list of top-level declarations.
data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where
FiddleUnit ::
- { -- | List of declarations.
- fiddleDecls :: [Directed FiddleDecl stage f a],
- -- | The interface for this FiddleUnit. Early on, this is just () because
+ { -- | The interface for this FiddleUnit. Early on, this is just () because
-- not enough information is provided to determine the interface..
fiddleUnitInterface :: FiddleUnitInterface stage,
+ -- | List of declarations.
+ fiddleDecls :: [Directed FiddleDecl stage f a],
-- | Annotation for the 'FiddleUnit'.
fiddleUnitAnnot :: a
} ->
diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs
index 5be6355..24c7da0 100644
--- a/src/Language/Fiddle/Compiler.hs
+++ b/src/Language/Fiddle/Compiler.hs
@@ -4,6 +4,7 @@
module Language.Fiddle.Compiler where
+import Control.Arrow (Arrow (first, second))
import Control.Monad (when)
import Control.Monad.Identity (Identity)
import Control.Monad.RWS (RWS, RWST, evalRWS, mapRWS, runRWS)
@@ -18,6 +19,7 @@ import System.IO (hPutStrLn, stderr)
import Text.Parsec (SourcePos, sourceColumn, sourceLine, sourceName)
data Level = Error | Warning | Info
+ deriving (Eq, Ord, Show, Read, Enum)
data Diagnostic = Diagnostic Level String SourceSpan
@@ -50,7 +52,10 @@ pushState cp = do
compile :: Compile s a -> s -> ([Diagnostic], Maybe a)
compile (Compile fn) initState = do
- let (a, _, w) = runRWS (runMaybeT fn) () initState in (w, a)
+ let (a, _, w) = runRWS (runMaybeT fn) () initState
+ in if hasError w then (w, Nothing) else (w, a)
+ where
+ hasError = any (\(Diagnostic e _ _) -> e == Error)
compile_ :: (Default s) => Compile s a -> ([Diagnostic], Maybe a)
compile_ c = compile c def
@@ -96,6 +101,12 @@ fromMayberOrFail sourceSpan err Nothing = do
compilationFailure
fromMayberOrFail _ _ (Just a) = return a
+-- data IOActionExtraData = IOActionExtraData
+-- { parseFile :: FilePath -> IO (TreeType FiddleUnit Parsed),
+-- stage3Compile :: TreeType FiddleUnit Parsed ->
+-- TreeType FiddleUnit Checked
+-- }
+
-- | 'CompilationPhase' represents a phase in the compilation process.
-- It consists of an IO action that performs necessary side effects or state
-- preparations before the next stage, and a function that transforms the
@@ -111,8 +122,8 @@ data CompilationPhase stageFrom stageTo where
-- only time a side effect may be performed.
ioAction ::
privateFlags ->
- FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) ->
- IO privateState,
+ TreeType FiddleUnit Parsed ->
+ IO ([Diagnostic], Maybe privateState),
-- | 'nextStage' is the function that transforms a 'FiddleUnit' from
-- the current stage ('stageFrom') to the next stage ('stageTo'). It
-- uses the private state obtained from 'ioAction' and outputs a
@@ -145,7 +156,16 @@ thenPhase
(CompilationPhase optParse2 ioAction2 compile2) =
CompilationPhase
((,) <$> optParse1 <*> optParse2)
- (\(f1, f2) unit -> (,) <$> ioAction1 f1 unit <*> ioAction2 f2 unit)
+ ( \(f1, f2) unit -> do
+ (diags1, mst1) <- ioAction1 f1 unit
+ case mst1 of
+ Nothing -> return (diags1, Nothing)
+ Just st1 -> do
+ (diags2, mst2) <- ioAction2 f2 unit
+ return $ case mst2 of
+ Nothing -> (diags1 ++ diags2, Nothing)
+ Just st2 -> (diags1 ++ diags2, Just (st1, st2))
+ )
( \(f1, f2) (s1, s2) firstStage -> do
secondStage <- compile1 f1 s1 firstStage
compile2 f2 s2 secondStage
@@ -174,7 +194,9 @@ execCompilationPipelineWithCmdline
(CompilationPhase flagsParser ioAction rest) = do
fmap
( \opts ast -> do
- s <- ioAction opts ast
- return $ compile_ $ rest opts s ast
+ (diags, ms) <- ioAction opts ast
+ case ms of
+ Just s -> return $ first (diags ++) $ compile_ $ rest opts s ast
+ Nothing -> return (diags, Nothing)
)
flagsParser
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 908db52..abfbb9b 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -23,7 +23,7 @@ import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Void
@@ -33,8 +33,8 @@ import GHC.TypeLits
import Language.Fiddle.Ast
import Language.Fiddle.Compiler
import Language.Fiddle.Internal.Scopes
-import Language.Fiddle.Internal.UnitInterface
-import Language.Fiddle.Types (Commented (unCommented), SourceSpan)
+import Language.Fiddle.Internal.UnitInterface as UnitInterface
+import Language.Fiddle.Types (Comment (DocComment), Commented (Commented, unCommented), SourceSpan)
import Text.Printf (printf)
import Prelude hiding (unzip)
@@ -57,14 +57,14 @@ type SizeBytes = Word32
consistencyCheckPhase ::
CompilationPhase Expanded Checked
consistencyCheckPhase =
- CompilationPhase (pure ()) (\_ _ -> return ()) (\_ _ -> checkConsistency)
+ CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> checkConsistency)
checkConsistency ::
FiddleUnit Expanded I Annot ->
Compile () (FiddleUnit Checked I Annot)
checkConsistency =
fmap snd
- . subCompile (GlobalState mempty mempty)
+ . subCompile (GlobalState mempty mempty mempty)
. advanceStage (LocalState mempty)
instance CompilationStage Checked where
@@ -81,7 +81,11 @@ instance CompilationStage Expanded where
type StageFunctor Expanded = Identity
type StageAnnotation Expanded = Commented SourceSpan
-instance AdvanceStage Expanded FiddleUnit
+instance AdvanceStage Expanded FiddleUnit where
+ advanceStage localState (FiddleUnit _ decls a) = do
+ decls' <- mapM (advanceStage localState) decls
+ intf <- gets unitInterface
+ return $ FiddleUnit intf decls' a
-- advanceStage localState (FiddleUnit decls _ annot) = do
@@ -107,7 +111,41 @@ deriving instance AdvanceStage Expanded EnumConstantDecl
deriving instance AdvanceStage Expanded PackageBody
-deriving instance AdvanceStage Expanded ImportStatement
+instance AdvanceStage Expanded ImportStatement where
+ modifyState
+ ( ImportStatement
+ { importInterface =
+ ( UnitInterface
+ { rootScope = unitScope,
+ dependencies = importDependencies
+ }
+ )
+ }
+ )
+ ls = do
+ modify'
+ ( \s@GlobalState
+ { globalScope = globalScope,
+ unitInterface = unitInterface
+ } ->
+ s
+ { globalScope =
+ unitInterfaceScopeToGlobalScope unitScope <> globalScope,
+ unitInterface =
+ unitInterface
+ { dependencies =
+ importDependencies ++ dependencies unitInterface
+ }
+ }
+ )
+ return ls
+ where
+ unitInterfaceScopeToGlobalScope =
+ fmap
+ ( \(Annotated _ _ exportedValue) -> case exportedValue of
+ ExportedBitsType sz -> Left sz
+ ExportedObjType sz -> Right sz
+ )
deriving instance (AdvanceStage Expanded t) => AdvanceStage Expanded (Directed t)
@@ -119,9 +157,9 @@ instance AdvanceStage Expanded ObjTypeBody where
instance AdvanceStage Expanded FiddleDecl where
modifyState t s = case t of
- (BitsDecl id typ a) -> do
+ (BitsDecl id typ annotation) -> do
typeSize <- getTypeSize typ
- insertTypeSize s id typeSize
+ insertTypeSize annotation s id typeSize
return s
(PackageDecl n _ _) -> do
let strs = nameToList n
@@ -139,6 +177,22 @@ instance AdvanceStage Expanded FiddleDecl where
}
_ -> return s
+ customAdvanceStage t (LocalState scopePath) = case t of
+ (ObjTypeDecl ident (Identity body) annot) -> do
+ (body', size) <- objTypeBodyToStage3 (LocalState scopePath) body 0
+
+ let fullName =
+ NonEmpty.prependList
+ (currentScope scopePath)
+ (NonEmpty.singleton (Text.unpack (identifierName ident)))
+
+ ui <- gets unitInterface
+ let ui' = insertIntoUnitInterface fullName ui annot (ExportedObjType size)
+ modify' $ \gs -> gs {unitInterface = ui'}
+
+ return $ Just $ ObjTypeDecl ident (Identity body') annot
+ _ -> return Nothing
+
nameToList :: Name f a -> [String]
nameToList (Name idents _) = map (\(Identifier (Text.unpack -> s) _) -> s) (toList idents)
@@ -444,9 +498,9 @@ lookupTypeSize (LocalState scopePath) (Name idents a) = do
case results of
-- Successfully resolved to a unique size
- [(_, Right sz)] -> return sz
+ [(_, Left sz)] -> return sz
-- Multiple ambiguous results found
- matches@(_ : _) -> do
+ matches@(_ : _ : _) -> do
-- Generate a list of ambiguous paths for error reporting
let ambiguousPaths =
map
@@ -467,7 +521,7 @@ lookupTypeSize (LocalState scopePath) (Name idents a) = do
compilationFailure
-- No matches found
- _ -> do
+ [] -> do
tell
[ Diagnostic
Error
@@ -528,23 +582,57 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
diagnosticError :: String -> Annot -> Compile a ()
diagnosticError str a = tell [Diagnostic Error str (unCommented a)]
+diagnosticInfo :: String -> Annot -> Compile a ()
+diagnosticInfo str a = tell [Diagnostic Info str (unCommented a)]
+
+insertIntoUnitInterface path ui (Commented comments srcspan) val =
+ let docComments =
+ mconcat
+ ( mapMaybe
+ ( \com -> do
+ (DocComment txt) <- Just com
+ return txt
+ )
+ comments
+ )
+ in ui
+ { rootScope =
+ insertScope path (Annotated srcspan docComments val) (rootScope ui)
+ }
+
insertTypeSize ::
+ Annot ->
LocalState ->
Identifier f Annot ->
SizeBits ->
Compile GlobalState ()
-insertTypeSize (LocalState scopePath) (Identifier s annot) size = do
+insertTypeSize annot (LocalState scopePath) (Identifier s idannot) size = do
modifyM $
- \state@GlobalState {globalScope = globalScope} ->
- let fullName =
- NonEmpty.prependList
- (currentScope scopePath)
- (NonEmpty.singleton (Text.unpack s))
- in case upsertScope fullName (Right size) globalScope of
- (Just _, _) -> do
- diagnosticError (printf "Duplicate type %s" s) annot
- compilationFailure
- (Nothing, n) -> return $ state {globalScope = n}
+ \state@GlobalState
+ { globalScope = globalScope,
+ unitInterface = unitInterface
+ } ->
+ let fullName =
+ NonEmpty.prependList
+ (currentScope scopePath)
+ (NonEmpty.singleton (Text.unpack s))
+ in case upsertScope fullName (Left size) globalScope of
+ (Just _, _) -> do
+ diagnosticError (printf "Duplicate type %s" s) idannot
+
+ compilationFailure
+ (Nothing, n) ->
+ let unitInterface' =
+ insertIntoUnitInterface
+ fullName
+ unitInterface
+ annot
+ (ExportedBitsType size)
+ in return $
+ state
+ { globalScope = n,
+ unitInterface = unitInterface'
+ }
where
modifyM fn = do
s <- get
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 7201686..1e8fbae 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -39,7 +39,7 @@ expandAst :: FiddleUnit CurrentStage I Annot -> Compile () (FiddleUnit Expanded
expandAst = fmap snd . subCompile (State [] []) . advanceStage (Path mempty)
expansionPhase :: CompilationPhase CurrentStage Expanded
-expansionPhase = CompilationPhase (pure ()) (\_ _ -> return ()) (\_ _ -> expandAst)
+expansionPhase = CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> expandAst)
-- Shorthand for Identity
type I = Identity
@@ -108,8 +108,8 @@ instance AdvanceStage CurrentStage FiddleDecl where
_ -> id
instance AdvanceStage CurrentStage FiddleUnit where
- advanceStage path (FiddleUnit decls a) =
- FiddleUnit <$> reconfigureFiddleDecls path decls <*> pure a
+ advanceStage path (FiddleUnit _ decls a) =
+ FiddleUnit () <$> reconfigureFiddleDecls path decls <*> pure a
instance AdvanceStage CurrentStage Expression where
advanceStage _ = \case
diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index 47eec72..4f076b8 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -8,12 +8,20 @@ module Language.Fiddle.Compiler.ImportResolution
)
where
+import qualified Codec.Compression.GZip as GZip
+import Control.Arrow (Arrow (second))
+import Control.Monad (filterM)
import Control.Monad.Identity (Identity)
-import Control.Monad.Writer.Lazy (MonadTrans (lift), MonadWriter (tell), WriterT (WriterT), execWriterT)
+import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
+import Control.Monad.Writer.Lazy (MonadTrans (lift), MonadWriter (tell), WriterT (WriterT, runWriterT), execWriterT)
+import Data.Aeson (decode, eitherDecode, encode)
+import qualified Data.ByteString.Lazy as BL
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
+import Data.Tuple (swap)
import Data.Typeable
import Language.Fiddle.Ast
import Language.Fiddle.Ast.FileInterface (ResolvedImport)
@@ -22,7 +30,9 @@ import Language.Fiddle.Compiler.Expansion
import Language.Fiddle.Internal.UnitInterface
import Language.Fiddle.Types
import Options.Applicative
-import System.IO (hPutStrLn, stderr)
+import System.Directory
+import System.FilePath
+import System.IO
import Text.Printf (printf)
newtype Flags = Flags
@@ -42,9 +52,15 @@ parseFlags =
)
importResolutionPhase ::
+ ( FilePath ->
+ IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+ ) ->
+ ( TreeType FiddleUnit Parsed ->
+ IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+ ) ->
CompilationPhase CurrentStage ImportsResolved
-importResolutionPhase =
- CompilationPhase parseFlags getImportResolutionState resolveImports
+importResolutionPhase parseFile compileToChecked =
+ CompilationPhase parseFlags (getImportResolutionState parseFile compileToChecked) resolveImports
type GlobalState = ()
@@ -54,11 +70,10 @@ type M = Compile GlobalState
type Annot = Commented SourceSpan
-data ImportError = ImportError Text (Maybe SourceSpan)
- deriving (Show)
+newtype ImportError = ImportError [Diagnostic]
newtype ResolvedImports = ResolvedImports
- { importMap :: Map Text (Either ImportError UnitInterface)
+ { importMap :: Map Text ([Diagnostic], Maybe UnitInterface)
}
deriving newtype (Semigroup, Monoid)
@@ -124,27 +139,45 @@ instance AdvanceStage CurrentStage ImportStatement where
Nothing -> do
diagnosticError "Failed to lookup imports (This is a bug)" a
return empty
- Just (Left err) -> do
- diagnosticError (printf "Error in import %s: %s" path (show err)) a
- return empty
- Just (Right val) -> return val
+ Just (diags, val) -> do
+ tell diags
+ return $ fromMaybe empty val
return $ ImportStatement path list v a
getImportResolutionState ::
+ ( FilePath ->
+ IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+ ) ->
+ ( TreeType FiddleUnit Parsed ->
+ IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+ ) ->
Flags ->
FiddleUnit CurrentStage Identity Annot ->
- IO ResolvedImports
-getImportResolutionState flags unit =
- execWriterT $
- walk doWalk unit ()
+ IO ([Diagnostic], Maybe ResolvedImports)
+getImportResolutionState parseFile compileToChecked flags unit = do
+ fmap
+ ( lookForFailures
+ . second Just
+ )
+ $ execWriterT
+ $ walk doWalk unit ()
where
- -- doWalk :: forall t'. (Walk t', Typeable t') => t' Identity Annot -> () -> WriterT ResolvedImports IO ()
+ doWalk :: forall t'. (Walk t', Typeable t') => t' Identity Annot -> () -> WriterT ([Diagnostic], ResolvedImports) IO ()
doWalk u () =
case () of
- () | Just (ImportStatement {importPath = path}) <- castTS u -> do
- lift $ hPutStrLn stderr $ "Import path: " ++ show path
- (return () :: WriterT ResolvedImports IO ())
+ ()
+ | Just
+ (ImportStatement {importPath = path, importStatementAnnot = (unCommented -> a)}) <-
+ castTS u -> do
+ (diagnostics, unitInterface) <-
+ lift $
+ ioGetImportInterface a (importDirectories flags) (Text.unpack path)
+
+ tell
+ ( [],
+ ResolvedImports $ Map.singleton path (diagnostics, unitInterface)
+ )
_ -> return ()
castTS ::
@@ -156,3 +189,95 @@ getImportResolutionState flags unit =
t' f a ->
Maybe (t CurrentStage f a)
castTS = cast
+
+ lookForFailures :: ([Diagnostic], Maybe a) -> ([Diagnostic], Maybe a)
+ lookForFailures (diags, a) = do
+ if any (\(Diagnostic e _ _) -> e == Error) diags
+ then (diags, Nothing)
+ else (diags, a)
+
+ ioGetImportInterface :: SourceSpan -> [FilePath] -> FilePath -> IO ([Diagnostic], Maybe UnitInterface)
+ ioGetImportInterface srcSpan imports fp = runCompl $ do
+ path <- findFileInImportPath srcSpan imports fp
+ let intf = interfaceFile path
+ valid <- lift2 $ interfaceFileValid path intf
+
+ let doFullCompile = do
+ parsed <- bump (parseFile path)
+ unitInterface <- addDependency path . fiddleUnitInterface <$> bump (compileToChecked parsed)
+ lift2 $ writeInterfaceFile intf unitInterface
+ return unitInterface
+
+ if valid
+ then do
+ e <- lift2 (readInterfaceFile intf)
+ case e of
+ Right val -> do
+ needFullRecompile <- lift2 $ checkNeedFullRecompile intf val
+ if needFullRecompile
+ then doFullCompile
+ else return val
+ Left err -> do
+ tell [Diagnostic Error err srcSpan]
+ MaybeT $ return Nothing
+ else doFullCompile
+
+ addDependency path unitInterface =
+ unitInterface {dependencies = path : dependencies unitInterface}
+
+ interfaceFile filePath = takeBaseName filePath <.> "fdi"
+
+ checkNeedFullRecompile intfFile (UnitInterface {dependencies = dependencies}) =
+ allM
+ ( \depfile -> do
+ timeDep <- getModificationTime depfile
+ timeIntf <- getModificationTime intfFile
+ return (timeIntf > timeDep)
+ )
+ dependencies
+
+ readInterfaceFile intfile =
+ eitherDecode . GZip.decompress <$> BL.readFile intfile
+
+ writeInterfaceFile intfile val =
+ BL.writeFile intfile $ GZip.compress (encode val)
+
+ interfaceFileValid :: FilePath -> FilePath -> IO Bool
+ interfaceFileValid originalPath intfPath = do
+ exists <- doesFileExist intfPath
+ if exists
+ then do
+ timeOrig <- getModificationTime originalPath
+ timeIntf <- getModificationTime intfPath
+ return (timeIntf > timeOrig)
+ else return False
+
+ findFileInImportPath :: SourceSpan -> [FilePath] -> FilePath -> Compl FilePath
+ findFileInImportPath sourceSpan paths path = do
+ realPaths <- lift2 $ filterM doesFileExist (map (++ ("/" ++ path)) paths)
+
+ case realPaths of
+ [] -> do
+ lift $ tell [Diagnostic Error (printf "Cannot find %s on path" path) sourceSpan]
+ MaybeT (return Nothing)
+ (a : _) -> return a
+
+bump :: IO ([Diagnostic], Maybe a) -> Compl a
+bump x = do
+ (diags, ma) <- lift2 x
+ lift $ tell diags
+ MaybeT (return ma)
+
+lift2 :: (Monad m, MonadTrans t0, MonadTrans t1) => m a -> t0 (t1 m) a
+lift2 = lift . lift
+
+runCompl :: Compl a -> IO ([Diagnostic], Maybe a)
+runCompl c = swap <$> runWriterT (runMaybeT c)
+
+type Compl a = MaybeT (WriterT [Diagnostic] IO) a
+
+allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+allM _ [] = return True
+allM fn (a : as) = do
+ b <- fn a
+ if b then allM fn as else return False
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index ef53e31..01549b7 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -33,7 +33,8 @@ type Context stage =
( Show (NumberType stage),
Typeable stage,
ToGenericSyntaxTreeValue (NumberType stage),
- Show (ImportInterface stage)
+ Show (ImportInterface stage),
+ Show (FiddleUnitInterface stage)
)
data GenericSyntaxTree f a where
@@ -79,17 +80,17 @@ 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 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 (GenericSyntaxTree f (Maybe Value)) where
toJSON = \case
diff --git a/src/Language/Fiddle/Internal/Scopes.hs b/src/Language/Fiddle/Internal/Scopes.hs
index eea4c6f..ac6f7d1 100644
--- a/src/Language/Fiddle/Internal/Scopes.hs
+++ b/src/Language/Fiddle/Internal/Scopes.hs
@@ -3,6 +3,8 @@
module Language.Fiddle.Internal.Scopes where
import Control.Monad (forM)
+import Data.Aeson
+import Data.Aeson.Key
import Data.List (inits, intercalate)
import Data.List.NonEmpty (NonEmpty (..), prependList)
import Data.Map (Map)
@@ -64,6 +66,9 @@ upsertScope (s :| (a : as)) v (Scope ss sv) =
(replaced, subscope') = upsertScope (a :| as) v subscope
in (replaced, Scope (Map.insert s subscope' ss) sv)
+insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
+insertScope p s = snd . upsertScope p s
+
-- insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
-- insertScope a b = snd . upsertScope a b
@@ -108,3 +113,17 @@ lookupScopeWithPath (ScopePath current others) key scope =
case lookupScope (prependList prefix key) scope of
Just s -> [(prependList prefix key, s)]
Nothing -> []
+
+instance (ToJSONKey k, ToJSON v, Ord k) => ToJSON (Scope k v) where
+ toJSON (Scope subScopes scopeValues) =
+ object
+ [ fromString "subScopes" .= toJSON subScopes,
+ fromString "scopeValues" .= toJSON scopeValues
+ ]
+
+instance (FromJSONKey k, FromJSON v, Ord k) => FromJSON (Scope k v) where
+ parseJSON (Object v) =
+ Scope
+ <$> v .: fromString "subScopes"
+ <*> v .: fromString "scopeValues"
+ parseJSON _ = fail "Expected an object for Scope"
diff --git a/src/Language/Fiddle/Internal/UnitInterface.hs b/src/Language/Fiddle/Internal/UnitInterface.hs
index 1f12c4c..b18b98b 100644
--- a/src/Language/Fiddle/Internal/UnitInterface.hs
+++ b/src/Language/Fiddle/Internal/UnitInterface.hs
@@ -1,5 +1,8 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Language.Fiddle.Internal.UnitInterface where
+import Data.Aeson
import Data.Text
import Data.Word
import Language.Fiddle.Internal.Scopes (Scope)
@@ -24,6 +27,13 @@ data UnitInterface where
UnitInterface
deriving (Eq, Ord, Show)
+instance Semigroup UnitInterface where
+ (<>) (UnitInterface s d) (UnitInterface s1 d1) =
+ UnitInterface (s <> s1) (d <> d1)
+
+instance Monoid UnitInterface where
+ mempty = UnitInterface mempty mempty
+
data ExportedValue where
ExportedBitsType ::
{exportBitsTypeSize :: Word32} ->
@@ -32,3 +42,51 @@ data ExportedValue where
{exportObjTypeSize :: Word32} ->
ExportedValue
deriving (Show, Eq, Ord)
+
+instance (ToJSON a) => ToJSON (Annotated a) where
+ toJSON (Annotated span doc internal) =
+ object
+ [ "sourceSpan" .= span,
+ "docComment" .= doc,
+ "internal" .= internal
+ ]
+
+instance (FromJSON a) => FromJSON (Annotated a) where
+ parseJSON = withObject "Annotated" $ \v ->
+ Annotated
+ <$> v .: "sourceSpan"
+ <*> v .: "docComment"
+ <*> v .: "internal"
+
+instance ToJSON UnitInterface where
+ toJSON (UnitInterface rootScope dependencies) =
+ object
+ [ "rootScope" .= rootScope,
+ "dependencies" .= dependencies
+ ]
+
+instance FromJSON UnitInterface where
+ parseJSON = withObject "UnitInterface" $ \v ->
+ UnitInterface
+ <$> v .: "rootScope"
+ <*> v .: "dependencies"
+
+instance ToJSON ExportedValue where
+ toJSON (ExportedBitsType size) =
+ object
+ [ "type" .= String "ExportedBitsType",
+ "size" .= size
+ ]
+ toJSON (ExportedObjType size) =
+ object
+ [ "type" .= String "ExportedObjType",
+ "size" .= size
+ ]
+
+instance FromJSON ExportedValue where
+ parseJSON = withObject "ExportedValue" $ \v -> do
+ typ <- v .: "type"
+ case typ of
+ String "ExportedBitsType" -> ExportedBitsType <$> v .: "size"
+ String "ExportedObjType" -> ExportedObjType <$> v .: "size"
+ _ -> fail "Unknown ExportedValue type"
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index d41cc64..8dfaaae 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -52,9 +52,14 @@ isComment (Token t _) =
stripTrailingComments :: [Token s] -> [Token s]
stripTrailingComments = reverse . dropWhile isComment . reverse
-directedP :: Pa t -> PaS (Directed t 'Parsed)
-directedP subparser = withMeta $ do
- Directed <$> many directiveP <*> subparser
+directedP :: (Annotated (t Parsed)) => Pa t -> PaS (Directed t 'Parsed)
+directedP subparser = withMetaLeaveComments $ do
+ comments <- many commentP
+ Directed <$> many directiveP <*> pushComments comments subparser
+
+pushComments :: (Annotated t) => [Comment] -> PaS t -> PaS t
+pushComments comments subparse = do
+ setAnnot (\(Commented coms a) -> Commented (comments ++ coms) a) <$> subparse
directiveP :: PaS Directive
directiveP =
@@ -103,7 +108,7 @@ directiveExpressionP = withMeta $ do
fiddleUnit :: Pa FiddleUnit
fiddleUnit = do
withMeta
- ( FiddleUnit <$> many1 (directedP fiddleDeclP <* tok TokSemi)
+ ( FiddleUnit () <$> many1 (directedP fiddleDeclP <* tok TokSemi)
)
<* many commentP
@@ -359,7 +364,7 @@ defer p0 pb = do
packageBodyP :: Pa PackageBody
packageBodyP =
- withMeta $
+ withMetaLeaveComments $
PackageBody
<$> many
( directedP $
@@ -399,6 +404,15 @@ withMeta p = do
end <- getPosition
return $ fn (Commented comments (SourceSpan start end))
+-- Takes a some parsable thing p and automatically parses the comments before
+-- and after and sets the positions and adds it to the annotation.
+withMetaLeaveComments :: P (Commented SourceSpan -> b) -> P b
+withMetaLeaveComments p = do
+ start <- getPosition
+ fn <- p
+ end <- getPosition
+ return $ fn (Commented [] (SourceSpan start end))
+
token :: (T -> Maybe a) -> ParsecT S u Identity a
token fn =
Text.Parsec.token
diff --git a/src/Language/Fiddle/Types.hs b/src/Language/Fiddle/Types.hs
index 0f3b5b1..047ace4 100644
--- a/src/Language/Fiddle/Types.hs
+++ b/src/Language/Fiddle/Types.hs
@@ -1,10 +1,14 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Language.Fiddle.Types where
+import Data.Aeson
+import Data.Text (Text, pack, splitOn, unpack)
import Text.Parsec (SourcePos)
-import Data.Text (Text)
+import Text.Parsec.Pos
data Comment = NormalComment Text | DocComment Text
- deriving(Show)
+ deriving (Show)
data SourceSpan = SourceSpan
{ sourceStart :: !SourcePos,
@@ -12,5 +16,39 @@ data SourceSpan = SourceSpan
}
deriving (Eq, Ord, Show)
-data Commented a = Commented { comments :: ![Comment], unCommented :: !a }
- deriving (Show)
+data Commented a = Commented {comments :: ![Comment], unCommented :: !a}
+ deriving (Show)
+
+-- Helper to create the compressed span string
+formatSpan :: SourceSpan -> String
+formatSpan (SourceSpan ss se) =
+ let sl = sourceLine ss
+ sc = sourceColumn ss
+ fname = sourceName ss
+ el = sourceLine se
+ ec = sourceColumn se
+ in fname ++ ":" ++ show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec
+
+-- Helper to parse the compressed span string
+parseSpan :: String -> Maybe (String, Int, Int, Int, Int)
+parseSpan str = do
+ let parts = map (splitOn ":") $ splitOn "-" (pack str)
+
+ case parts of
+ [[fname, sl, sc], [el, ec]] ->
+ Just (unpack fname, read $ unpack sl, read $ unpack sc, read $ unpack el, read $ unpack ec)
+ _ -> Nothing
+
+-- ToJSON and FromJSON instances
+instance ToJSON SourceSpan where
+ toJSON span =
+ object
+ ["span" .= formatSpan span]
+
+instance FromJSON SourceSpan where
+ parseJSON = withObject "SourceSpan" $ \v -> do
+ spanStr <- v .: "span"
+ case parseSpan spanStr of
+ Just (fname, sl, sc, el, ec) ->
+ return $ SourceSpan (newPos fname sl sc) (newPos fname el ec)
+ Nothing -> fail "Invalid span format"
diff --git a/src/Main.hs b/src/Main.hs
index 352a8cc..393fb69 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,12 +2,10 @@ module Main where
import Control.Monad (forM_)
import Control.Monad.Identity (Identity)
-import Control.Monad.Writer
-import Data.Aeson (Value (Null), encode)
+import Data.Aeson (Value (Null, String), encode)
import qualified Data.ByteString.Lazy.Char8 as BL
-import Data.Data (cast)
import qualified Data.Text as Text
-import qualified Data.Text.IO
+import qualified Data.Text.IO as TextIO
import Data.Typeable
import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess))
import Language.Fiddle.Ast
@@ -16,80 +14,141 @@ import Language.Fiddle.Compiler.ConsistencyCheck
import Language.Fiddle.Compiler.Expansion
import Language.Fiddle.Compiler.ImportResolution
import Language.Fiddle.Compiler.Stage0
-import Language.Fiddle.GenericTree (GenericSyntaxTree (..), ToGenericSyntaxTree (toGenericSyntaxTree), alterGenericSyntaxTree)
+import Language.Fiddle.GenericTree
+ ( GenericSyntaxTree (..),
+ ToGenericSyntaxTree (toGenericSyntaxTree),
+ alterGenericSyntaxTree,
+ )
import qualified Language.Fiddle.Parser
import qualified Language.Fiddle.Tokenizer
+import Language.Fiddle.Types (Commented (unCommented))
import Options.Applicative
import qualified System.Environment as System
import System.Exit (exitWith)
+import System.IO
-compilationPipeline =
- importResolutionPhase >>> expansionPhase >>> consistencyCheckPhase
+-- compilationPipeline :: _ -> _ -> CompilationPhase Parsed Checked
+compilationPipeline parse compile =
+ importResolutionPhase parse compile >>> expansionPhase >>> consistencyCheckPhase
-newtype GlobalFlags
- = GlobalFlags
- { flagsInputFile :: String
- }
+-- | Global flags for the compiler.
+newtype GlobalFlags = GlobalFlags
+ {flagsInputFile :: String}
+-- | Parse global flags from command line arguments.
parseGlobalFlags :: Parser GlobalFlags
-parseGlobalFlags =
- GlobalFlags
- <$> argument str (metavar "INPUT" <> help "Input file")
+parseGlobalFlags = GlobalFlags <$> argument str (metavar "INPUT" <> help "Input file")
-main :: IO ()
-main = do
- (globalFlags, compilationPipelineAction) <-
- execParser $
- info
- ( ( (,)
- <$> parseGlobalFlags
- <*> execCompilationPipelineWithCmdline compilationPipeline
- )
- <**> helper
+-- | Parse the input file into the initial AST stages.
+doParse :: String -> IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+doParse filePath = do
+ text <- TextIO.readFile filePath
+ return $ compile_ $ toStage0 filePath text >>= toStage1
+
+-- | Run the compilation pipeline with the given command-line arguments and AST.
+runCompilationPipeline ::
+ [String] ->
+ TreeType FiddleUnit Parsed ->
+ IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+runCompilationPipeline argv tree =
+ case fromArgs argv of
+ Failure failure ->
+ return
+ ( [Diagnostic Error "Internal parsing failure (this is a bug)." (unCommented $ annot tree)],
+ Nothing
+ )
+ Success (_, pipelineAction) -> pipelineAction tree
+
+-- | Parse command-line arguments into global flags and a compilation action.
+fromArgs ::
+ [String] ->
+ ParserResult
+ ( GlobalFlags,
+ TreeType FiddleUnit Parsed ->
+ IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+ )
+fromArgs argv =
+ execParserPure
+ defaultPrefs
+ ( info
+ ( (,)
+ <$> parseGlobalFlags
+ <*> execCompilationPipelineWithCmdline
+ (compilationPipeline doParse (runCompilationPipeline argv))
+ <**> helper
)
( fullDesc
<> progDesc "Compile Fiddle Files"
- <> header "fiddlec - A compiler for fiddle files"
+ <> header "fiddlec - A compiler for Fiddle files"
)
+ )
+ argv
+main :: IO ()
+main = do
+ argv <- System.getArgs
+ (globalFlags, compilationAction) <- parseCommandLineArgs argv
let filePath = flagsInputFile globalFlags
- text <- Data.Text.IO.readFile filePath
- let maybeParsedAst = compile_ $ toStage0 filePath text >>= toStage1
+ maybeParsedAst <- parseInputFile filePath
case maybeParsedAst of
(priorDiags, Just ast) -> do
- ((priorDiags ++) -> diags, ma) <- compilationPipelineAction ast
- ec <-
- case ma of
- Just ast -> do
- putStrLn $
- BL.unpack $
- encode $
- alterGenericSyntaxTree cleanupIdentifiers $
- toGenericSyntaxTree $
- fmap
- (const (Nothing :: Maybe Value))
- ast
- return ExitSuccess
- Nothing -> do
- putStrLn "\x1b[1;31mCompilation Failed\x1b[0m"
- return (ExitFailure 1)
-
- forM_ diags printDiagnostic
- exitWith ec
- (diags, _) -> do
- putStrLn "\x1b[1;31mParsing Failed\x1b[0m"
+ ((priorDiags ++) -> diags, ma) <- compilationAction ast
+ exitCode <- processCompilationResult ma
forM_ diags printDiagnostic
+ exitWith exitCode
+ (diags, _) -> handleParsingFailure diags
+
+-- | Parse command-line arguments, exiting on failure.
+parseCommandLineArgs ::
+ [String] ->
+ IO
+ ( GlobalFlags,
+ TreeType FiddleUnit Parsed ->
+ IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+ )
+parseCommandLineArgs argv =
+ case fromArgs argv of
+ Failure failure -> do
+ hPutStrLn stderr (fst $ renderFailure failure "")
exitWith (ExitFailure 1)
+ Success v -> return v
+
+-- | Parse the input file into the initial AST.
+parseInputFile :: String -> IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+parseInputFile filePath = do
+ text <- TextIO.readFile filePath
+ return $ compile_ $ toStage0 filePath text >>= toStage1
+
+-- | Process the compilation result, printing the output and returning the exit code.
+processCompilationResult :: Maybe (TreeType FiddleUnit Checked) -> IO ExitCode
+processCompilationResult ma =
+ case ma of
+ Just ast -> do
+ putStrLn $
+ BL.unpack $
+ encode $
+ alterGenericSyntaxTree cleanupIdentifiers $
+ toGenericSyntaxTree $
+ fmap (Just . String . Text.pack . show) ast
+ return ExitSuccess
+ Nothing -> do
+ putStrLn "\x1b[1;31mCompilation Failed\x1b[0m"
+ return (ExitFailure 1)
+
+-- | Handle parsing failures by printing diagnostics and exiting with an error code.
+handleParsingFailure :: [Diagnostic] -> IO ()
+handleParsingFailure diags = do
+ putStrLn "\x1b[1;31mParsing Failed\x1b[0m"
+ forM_ diags printDiagnostic
+ exitWith (ExitFailure 1)
+-- | Clean up identifiers in the generic syntax tree for serialization.
cleanupIdentifiers :: GenericSyntaxTree Identity a -> Maybe (GenericSyntaxTree Identity a)
cleanupIdentifiers (SyntaxTreeObject _ _ _ tr)
- | (Just (Identifier n _)) <- castT tr =
+ | Just (Identifier n _) <- castT tr =
Just $ SyntaxTreeValue (Text.unpack n)
where
- castT ::
- (Typeable t, Typeable f, Typeable a, Typeable t') =>
- t f a ->
- Maybe (t' f a)
+ castT :: (Typeable t, Typeable f, Typeable a, Typeable t') => t f a -> Maybe (t' f a)
castT = cast
cleanupIdentifiers _ = Nothing
generated by cgit (git 2.34.1) at 2025-04-28 20:04:40 +0000