diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler.hs | 64 |
1 files changed, 46 insertions, 18 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 |