summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Language/Fiddle/Compiler.hs64
-rw-r--r--src/Language/Fiddle/Compiler/ImportResolution.hs61
-rw-r--r--src/Main.hs162
3 files changed, 82 insertions, 205 deletions
diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs
index 049d533..812d4f6 100644
--- a/src/Language/Fiddle/Compiler.hs
+++ b/src/Language/Fiddle/Compiler.hs
@@ -11,16 +11,25 @@ import Control.Monad.RWS
import Control.Monad.Trans.Maybe
import Control.Monad.Writer
import Data.Default
+import Data.Typeable
import Language.Fiddle.Ast
import Language.Fiddle.Types
import Options.Applicative
import System.IO (hPutStrLn, stderr)
+import qualified Data.ByteString.Lazy.Char8 as BL
import Text.Parsec (sourceColumn, sourceLine, sourceName)
+import Data.Aeson (FromJSON, ToJSON (toJSON), encode)
+import GHC.Generics (Generic)
data Level = Error | Warning | Info
- deriving (Eq, Ord, Show, Read, Enum)
+ deriving (Eq, Ord, Show, Read, Enum, ToJSON, FromJSON, Generic)
-data Diagnostic = Diagnostic Level String SourceSpan
+data Diagnostic = Diagnostic {
+ diagnosticLevel :: Level,
+ diagnosticMesasge :: String,
+ diagnosticLocation :: SourceSpan
+ }
+ deriving (Generic, ToJSON, FromJSON, Typeable)
emitDiagnosticError :: String -> Commented SourceSpan -> Compile a ()
emitDiagnosticError str a = tell [Diagnostic Error str (unCommented a)]
@@ -31,16 +40,21 @@ emitDiagnosticWarning str a = tell [Diagnostic Warning str (unCommented a)]
emitDiagnosticInfo :: String -> Commented SourceSpan -> Compile a ()
emitDiagnosticInfo str a = tell [Diagnostic Info str (unCommented a)]
-newtype Compile s a = Compile (MaybeT (RWS () [Diagnostic] s) a)
+data Artifact where
+ Artifact :: forall t. (Typeable t) => t -> Artifact
+
+newtype Compile s a = Compile (MaybeT (RWS () ([Diagnostic], [Artifact]) s) a)
deriving newtype (Functor, Applicative, Monad)
compilationFailure :: Compile s a
compilationFailure = Compile $ MaybeT (return Nothing)
instance MonadWriter [Diagnostic] (Compile s) where
- tell = Compile . tell
- listen (Compile fn) = Compile $ listen fn
- pass (Compile fn) = Compile $ pass fn
+ tell t = Compile $ tell (t, [])
+ listen (Compile fn) = Compile $ do
+ (a, (ds, _)) <- listen fn
+ return (a, ds)
+ pass (Compile mfun) = Compile $ pass (second first <$> mfun)
instance MonadState s (Compile s) where
get = Compile get
@@ -53,28 +67,34 @@ subCompile s' (Compile mtrws) = Compile $ do
tell w
MaybeT $ return $ fmap (s,) a
+emitArtifact :: Artifact -> Compile s ()
+emitArtifact art = Compile $ tell ([], [art])
+
pushState :: Compile s a -> Compile s a
pushState cp = do
s <- get
snd <$> subCompile s cp
-compile :: Compile s a -> s -> ([Diagnostic], Maybe a)
+compile :: Compile s a -> s -> ([Diagnostic], [Artifact], Maybe a)
compile (Compile fn) initState = do
- let (a, _, w) = runRWS (runMaybeT fn) () initState
- in if hasError w then (w, Nothing) else (w, a)
+ let (a, _, (w, as)) = runRWS (runMaybeT fn) () initState
+ in if hasError w then (w, as, Nothing) else (w, as, a)
where
hasError = any (\(Diagnostic e _ _) -> e == Error)
-compile_ :: (Default s) => Compile s a -> ([Diagnostic], Maybe a)
+compile_ :: (Default s) => Compile s a -> ([Diagnostic], [Artifact], Maybe a)
compile_ c = compile c def
hoistMaybe :: Maybe a -> Compile s a
hoistMaybe = Compile . MaybeT . return
-newtype DiagnosticFormat = DiagnosticFormat (Diagnostic -> String)
+newtype DiagnosticFormat = DiagnosticFormat ([Diagnostic] -> String)
+
+jsonFormat :: DiagnosticFormat
+jsonFormat = DiagnosticFormat $ BL.unpack . encode . toJSON
coloredFormat :: DiagnosticFormat
-coloredFormat = DiagnosticFormat $ \(Diagnostic level message (SourceSpan pos1 pos2)) ->
+coloredFormat = DiagnosticFormat $ \diags -> unlines $ map (\(Diagnostic level message (SourceSpan pos1 pos2)) ->
execWriter $ do
case level of
Error -> tell "\x1b[01;31mError "
@@ -90,18 +110,22 @@ coloredFormat = DiagnosticFormat $ \(Diagnostic level message (SourceSpan pos1 p
tellPos pos2
tell "): "
tell (unwords $ words message)
+ ) diags
where
tellPos pos = do
tell (show $ sourceLine pos)
tell ":"
tell (show $ sourceColumn pos)
-diagnosticToString :: DiagnosticFormat -> Diagnostic -> String
-diagnosticToString (DiagnosticFormat f) = f
+diagnosticsToString :: DiagnosticFormat -> [Diagnostic] -> String
+diagnosticsToString (DiagnosticFormat f) = f
+
+printDiagnostics :: DiagnosticFormat -> [Diagnostic] -> IO ()
+printDiagnostics fmt d = hPutStrLn stderr (diagnosticsToString fmt d)
printDiagnostic :: Diagnostic -> IO ()
printDiagnostic d =
- hPutStrLn stderr (diagnosticToString coloredFormat d)
+ hPutStrLn stderr (diagnosticsToString coloredFormat [d])
fromMayberOrFail :: SourceSpan -> String -> Maybe a -> Compile s a
fromMayberOrFail sourceSpan err Nothing = do
@@ -127,6 +151,9 @@ pureCompilationPhase ::
pureCompilationPhase fn =
CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> fn)
+emitArtifacts :: [Artifact] -> Compile s ()
+emitArtifacts arts = Compile $ tell ([], arts)
+
-- data IOActionExtraData = IOActionExtraData
-- { parseFile :: FilePath -> IO (TreeType FiddleUnit Parsed),
-- stage3Compile :: TreeType FiddleUnit Parsed ->
@@ -140,7 +167,7 @@ pureCompilationPhase fn =
data CompilationPhase stageFrom stageTo where
CompilationPhase ::
forall privateFlags privateState stageFrom stageTo.
- (CompilationStage stageFrom) =>
+ -- (CompilationStage stageFrom) =>
{ optionsParser :: Parser privateFlags,
-- | 'ioAction' is an IO operation that runs after the ast is parsed. It
-- takes the parsed 'FiddleUnit' and performs some side effect
@@ -211,6 +238,7 @@ execCompilationPipelineWithCmdline ::
( FiddleUnit Parsed Identity (StageAnnotation Parsed) ->
IO
( [Diagnostic],
+ [Artifact],
Maybe
( FiddleUnit s' Identity (StageAnnotation s')
)
@@ -222,8 +250,8 @@ execCompilationPipelineWithCmdline
( \opts ast -> do
(diags, ms) <- ioAct opts ast
case ms of
- Just s -> return $ first (diags ++) $ compile_ $ rest opts s ast
- Nothing -> return (diags, Nothing)
+ Just s -> return $ (\(a, b, c) -> (diags ++ a, b, c)) $ compile_ $ rest opts s ast
+ Nothing -> return (diags, [], Nothing)
)
flagsParser
diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index b475801..f3ddee0 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -8,16 +8,19 @@ 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 (filterM, when)
import Control.Monad.Identity (Identity)
import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
import Control.Monad.Writer.Lazy (MonadTrans (lift), MonadWriter (tell), WriterT (..), execWriterT)
import Data.Aeson (eitherDecode, encode)
+import qualified Data.ByteString.Lazy as BL
import Data.Map (Map)
-import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text)
-import Data.Tuple (swap)
+import qualified Data.Text as Text
import Data.Typeable
import Language.Fiddle.Ast
import Language.Fiddle.Compiler
@@ -28,11 +31,7 @@ import Options.Applicative
import System.Directory
import System.FilePath
import Text.Printf (printf)
-
-import qualified Codec.Compression.GZip as GZip
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.Map as Map
-import qualified Data.Text as Text
+import Control.Monad.State (put)
newtype Flags = Flags
{ importDirectories :: [FilePath]
@@ -52,16 +51,16 @@ parseFlags =
importResolutionPhase ::
( FilePath ->
- IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+ IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Parsed))
) ->
( TreeType FiddleUnit Parsed ->
- IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+ IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
) ->
CompilationPhase CurrentStage ImportsResolved
importResolutionPhase parseFile compileToChecked =
CompilationPhase parseFlags (getImportResolutionState parseFile compileToChecked) resolveImports
-type GlobalState = ()
+type GlobalState = Bool
type LocalState = ResolvedImports
@@ -90,7 +89,17 @@ resolveImports ::
ResolvedImports ->
FiddleUnit CurrentStage I Annot ->
Compile () (FiddleUnit ImportsResolved I Annot)
-resolveImports _ = advanceStage
+resolveImports _ localState t = do
+ (b, a) <- subCompile False $ advanceStage localState t
+ if b
+ then compilationFailure
+ else return a
+
+-- | Mark the current compilation as failed, but allows the import resolution to
+-- continue in order to allow all import failures to be reported at the same
+-- time rather than as piecemeal.
+markFatal :: Compile Bool ()
+markFatal = put True
deriving instance AdvanceStage CurrentStage ObjTypeBody
@@ -132,19 +141,21 @@ instance AdvanceStage CurrentStage ImportStatement where
v <- case what of
Nothing -> do
emitDiagnosticError "Failed to lookup imports (This is a bug)" a
+ markFatal
return empty
Just (diags, val) -> do
tell diags
+ when (isNothing val) markFatal
return $ fromMaybe empty val
return $ ImportStatement path list v a
getImportResolutionState ::
( FilePath ->
- IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+ IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Parsed))
) ->
( TreeType FiddleUnit Parsed ->
- IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+ IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
) ->
Flags ->
FiddleUnit CurrentStage Identity Annot ->
@@ -164,7 +175,7 @@ getImportResolutionState parseFile compileToChecked flags unit = do
| Just
(ImportStatement {importPath = path, importStatementAnnot = (unCommented -> a)}) <-
castTS u -> do
- (diagnostics, unitInterface) <-
+ (diagnostics, _, unitInterface) <-
lift $
ioGetImportInterface a (importDirectories flags) (Text.unpack path)
@@ -190,7 +201,7 @@ getImportResolutionState parseFile compileToChecked flags unit = do
then (diags, Nothing)
else (diags, a)
- ioGetImportInterface :: SourceSpan -> [FilePath] -> FilePath -> IO ([Diagnostic], Maybe UnitInterface)
+ ioGetImportInterface :: SourceSpan -> [FilePath] -> FilePath -> IO ([Diagnostic], [Artifact], Maybe UnitInterface)
ioGetImportInterface srcSpan imports fp = runCompl $ do
path <- findFileInImportPath srcSpan imports fp
let intf = interfaceFile path
@@ -212,8 +223,8 @@ getImportResolutionState parseFile compileToChecked flags unit = do
then doFullCompile
else return val
Left err -> do
- tell [Diagnostic Warning "Doing recompile" srcSpan]
- tell [Diagnostic Warning err srcSpan]
+ tell ([Diagnostic Warning "Doing recompile" srcSpan], [])
+ tell ([Diagnostic Warning err srcSpan], [])
doFullCompile
else doFullCompile
@@ -254,23 +265,23 @@ getImportResolutionState parseFile compileToChecked flags unit = do
case realPaths of
[] -> do
- lift $ tell [Diagnostic Error (printf "Cannot find %s on path" path) sourceSpan]
+ 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 :: IO ([Diagnostic], [Artifact], Maybe a) -> Compl a
bump x = do
- (diags, ma) <- lift2 x
- lift $ tell diags
+ (diags, artifacts, ma) <- lift2 x
+ lift $ tell (diags, artifacts)
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)
+runCompl :: Compl a -> IO ([Diagnostic], [Artifact], Maybe a)
+runCompl c = (\(x, (y, z)) -> (y, z, x)) <$> runWriterT (runMaybeT c)
-type Compl a = MaybeT (WriterT [Diagnostic] IO) a
+type Compl a = MaybeT (WriterT ([Diagnostic], [Artifact]) IO) a
allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
allM _ [] = return True
diff --git a/src/Main.hs b/src/Main.hs
deleted file mode 100644
index 2e4ee7a..0000000
--- a/src/Main.hs
+++ /dev/null
@@ -1,162 +0,0 @@
-module Main where
-
-import Control.Monad (forM_)
-import Control.Monad.Identity (Identity)
-import Data.Aeson (ToJSON (..), Value (..), encode)
-import qualified Data.ByteString.Lazy.Char8 as BL
-import qualified Data.Text as Text
-import qualified Data.Text.IO as TextIO
-import Data.Typeable
-import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess))
-import Language.Fiddle.Ast
-import Language.Fiddle.Compiler
-import Language.Fiddle.Compiler.ConsistencyCheck
-import Language.Fiddle.Compiler.Expansion
-import Language.Fiddle.Compiler.ImportResolution
-import Language.Fiddle.Compiler.Qualification
-import Language.Fiddle.Compiler.Stage0
-import Language.Fiddle.GenericTree
-import Language.Fiddle.Types (Commented (unCommented), SourceSpan)
-import Options.Applicative
-import qualified System.Environment as System
-import System.Exit (exitWith)
-
-compilationPipeline ::
- ( FilePath ->
- IO
- ( [Diagnostic],
- Maybe
- ( FiddleUnit Parsed Identity (Commented SourceSpan)
- )
- )
- ) ->
- ( FiddleUnit Parsed Identity (Commented SourceSpan) ->
- IO
- ( [Diagnostic],
- Maybe
- (FiddleUnit Checked Identity (Commented SourceSpan))
- )
- ) ->
- CompilationPhase Parsed Checked
-compilationPipeline parse compile =
- importResolutionPhase parse compile
- >>> expansionPhase
- >>> qualificationPhase
- >>> consistencyCheckPhase
-
--- | 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")
-
--- | 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
- Success (_, pipelineAction) -> pipelineAction tree
- _ ->
- return
- ( [Diagnostic Error "Internal parsing failure (this is a bug)." (unCommented $ annot tree)],
- Nothing
- )
-
--- | 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"
- )
- )
- argv
-
-main :: IO ()
-main = do
- argv <- System.getArgs
- (globalFlags, compilationAction) <- parseCommandLineArgs argv
- let filePath = flagsInputFile globalFlags
-
- maybeParsedAst <- parseInputFile filePath
- case maybeParsedAst of
- (priorDiags, Just ast) -> do
- ((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 = handleParseResult (fromArgs argv)
-
--- | 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 . toJSON) 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 $ SyntaxTreeValue (String n)
- where
- 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-29 05:00:14 +0000