diff options
| -rw-r--r-- | goal.fiddle | 2 | ||||
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast.hs | 5 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler.hs | 116 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage0.hs | 61 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Stage1.hs | 9 | ||||
| -rw-r--r-- | src/Language/Fiddle/Parser.hs | 13 | ||||
| -rw-r--r-- | src/Main.hs | 37 |
8 files changed, 218 insertions, 26 deletions
diff --git a/goal.fiddle b/goal.fiddle index d37a2c7..b87f0e9 100644 --- a/goal.fiddle +++ b/goal.fiddle @@ -44,7 +44,7 @@ package gpio { * The output type. */ assert_pos(0x04); - reg (32) : { + reg ocfg_reg(32) : { otype_r : enum(1) { /** * The GPIO pin is capable of sinking to ground (for LOW) or providing diff --git a/package.yaml b/package.yaml index fe4e70b..2ca3b73 100644 --- a/package.yaml +++ b/package.yaml @@ -32,3 +32,4 @@ dependencies: - aeson - vector - bytestring + - data-default diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs index 7600006..60b9e11 100644 --- a/src/Language/Fiddle/Ast.hs +++ b/src/Language/Fiddle/Ast.hs @@ -189,13 +189,14 @@ data RegisterBitsTypeRef stage f a where AnonymousBitsType stage f a -> a -> RegisterBitsTypeRef 'Stage1 f a - {- (<expr>) - - The expression is just bits ... i.e. an integer. -} RegisterBitsJustBits :: - Expression stage f a -> a -> RegisterBitsTypeRef stage f a + Expression stage f a -> + a -> + RegisterBitsTypeRef stage f a instance Alter (RegisterBitsTypeRef stage) where alter ffn fn = \case diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs index af4e4d8..d3b519f 100644 --- a/src/Language/Fiddle/Compiler.hs +++ b/src/Language/Fiddle/Compiler.hs @@ -1,5 +1,119 @@ module Language.Fiddle.Compiler where +import Control.Monad.State +import Control.Monad.Writer +import Data.Default import Language.Fiddle.Ast +import Language.Fiddle.Types +import Text.Parsec (SourcePos, sourceColumn, sourceLine, sourceName) --- Converts a Stage1 AST to a Stage2 AST. +data Level = Error | Warning | Info + +data Diagnostic = Diagnostic Level String SourceSpan + +-- Compilation monad. Has diagnostics. Optionally produces a value. +data 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) + +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) + +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) + +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) + +-- 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) + +-- 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 + +-- Runs a compilation routine. It produces diagnostics and maybe a result. +-- Generally if the diagnostics contain an error, the result will be Nothing, +-- but if only Warnings are generated, then Just something will be returned. +-- +-- Note that there is no actual type-level mechanism restricting this function +-- 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_ :: (Default s) => Compile s a -> ([Diagnostic], Maybe a) +compile_ c = compile c def + +newtype DiagnosticFormat = DiagnosticFormat (Diagnostic -> String) + +coloredFormat :: DiagnosticFormat +coloredFormat = DiagnosticFormat $ \(Diagnostic level message (SourceSpan pos1 pos2)) -> + execWriter $ do + case level of + Error -> tell "\x1b[01;31mError " + Warning -> tell "\x1b[01;33mWarn " + Info -> tell "\x1b[01;37mInfo " + + tell "\x1b[0m" + tell (sourceName pos1) + tell "(" + tellPos pos1 + when (pos2 /= pos1) $ do + tell "-" + tellPos pos2 + tell "): " + tell (unwords $ words message) + where + tellPos pos = do + tell (show $ sourceLine pos) + tell ":" + tell (show $ sourceColumn pos) + +diagnosticToString :: DiagnosticFormat -> Diagnostic -> String +diagnosticToString (DiagnosticFormat f) = f + +printDiagnostic :: Diagnostic -> IO () +printDiagnostic d = + putStrLn (diagnosticToString coloredFormat d) diff --git a/src/Language/Fiddle/Compiler/Stage0.hs b/src/Language/Fiddle/Compiler/Stage0.hs new file mode 100644 index 0000000..d00d7cb --- /dev/null +++ b/src/Language/Fiddle/Compiler/Stage0.hs @@ -0,0 +1,61 @@ +module Language.Fiddle.Compiler.Stage0 (toStage0, toStage1) where + +import Control.Monad.Identity (Identity) +import Control.Monad.Writer +import qualified Data.Text +import Language.Fiddle.Ast +import Language.Fiddle.Compiler +import qualified Language.Fiddle.Parser +import Language.Fiddle.Types (Commented, SourceSpan(..)) +import Text.Parsec (ParseError, errorPos) +import Text.Parsec.Error (errorMessages, showErrorMessages) + +newtype Stage0Diagnostic = SyntaxError String + +toStage0 :: + String -> + Data.Text.Text -> + Compile () (FiddleUnit Stage1 (Either ParseError) (Commented SourceSpan)) +toStage0 filePath text = + case Language.Fiddle.Parser.parseFiddleText filePath text of + Left pe -> do + tell [parseErrorToDiagnostic pe] + hoistMaybe Nothing + Right a -> return a + +-- Gets the AST ready for Stage1 processing .This will report primarily +-- SyntaxErrors and errors parsing the tree. +-- +-- In the process, the tree is un-deferred and all parts of the +toStage1 :: + FiddleUnit Stage1 (Either ParseError) a -> + Compile () (FiddleUnit Stage1 Identity a) +toStage1 ast = do + alter + ( \case + (Left l) -> do + tell [parseErrorToDiagnostic l] + return (Left l) + r -> return r + ) + return + ast + + hoistMaybe $ + case squeeze ast of + (Left _) -> Nothing + (Right a) -> Just a + +parseErrorToDiagnostic :: ParseError -> Diagnostic +parseErrorToDiagnostic pe = + Diagnostic + Error + ( showErrorMessages + "or" + "unknown" + "expecting" + "unexpected" + "end of body or input (maybe a missing semicolon?)" + (errorMessages pe) + ) + (SourceSpan (errorPos pe) (errorPos pe)) diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs new file mode 100644 index 0000000..d3f3e10 --- /dev/null +++ b/src/Language/Fiddle/Compiler/Stage1.hs @@ -0,0 +1,9 @@ +module Language.Fiddle.Compiler.Stage1 (toStage2) where + +import Control.Monad.Identity (Identity) +import Language.Fiddle.Ast + +-- The second stage is a simplified version of the AST without anonymous +-- declarations. +toStage2 :: FiddleUnit Stage1 Identity a -> FiddleUnit Stage2 Identity a +toStage2 = undefined diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index 94fbbf9..c9c3c86 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -60,13 +60,10 @@ fiddleDecl = do t <- tokenType <$> anyToken case t of KWOption -> OptionDecl <$> ident <*> ident - KWPackage -> do - p <- - PackageDecl - <$> ident - <*> defer body packageBody - printNext - return p + KWPackage -> + PackageDecl + <$> ident + <*> defer body packageBody KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expression) KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitType) KWObjtype -> @@ -189,7 +186,7 @@ registerBitsTypeRef = do baseTypeRef = withMeta $ (RegisterBitsJustBits <$> exprInParen) - <|> (RegisterBitsAnonymousType <$> anonymousBitsType) + <|> (RegisterBitsAnonymousType <$> anonymousBitsType) <|> (RegisterBitsReference <$> ident) anonymousBitsType :: Pa AnonymousBitsType diff --git a/src/Main.hs b/src/Main.hs index ea41afe..92e9a1d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,16 +1,19 @@ module Main where -import qualified Language.Fiddle.Tokenizer -import qualified Language.Fiddle.Parser -import Language.Fiddle.Ast -import qualified Data.Text.IO -import qualified System.Environment as System import Control.Monad (forM_) import Control.Monad.Writer -import qualified Language.Fiddle.Parser -import Language.Fiddle.GenericTree (ToGenericSyntaxTree(toGenericSyntaxTree)) import Data.Aeson (encode) import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.Text.IO +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.GenericTree (ToGenericSyntaxTree (toGenericSyntaxTree)) +import qualified Language.Fiddle.Parser +import qualified Language.Fiddle.Tokenizer +import qualified System.Environment as System +import System.Exit (exitWith) main :: IO () main = do @@ -18,10 +21,16 @@ main = do case argv of [filePath] -> do - text <- Data.Text.IO.readFile filePath - case squeeze =<< Language.Fiddle.Parser.parseFiddleText filePath text of - Left pe -> putStrLn $ "Parse Error: " ++ show pe - Right ast -> do - putStrLn (BL.unpack $ encode $ toGenericSyntaxTree $ fmap (const ()) ast) - - _ -> putStrLn "Wrong Args" + text <- Data.Text.IO.readFile filePath + let (diags, ma) = compile_ $ 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" + exitWith (ExitFailure 1) + _ -> do + putStrLn "Wrong Args" + exitWith (ExitFailure 2) |