Crude compilation pipeline starting to take shape.

This simply does a Stage0 -> Stage1 conversion. Namely, parse the text,
check for syntax errors, squeeze the resulting ast and ... that's it.

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)