Add import resolution phase and also add a more abstractions around

compliation phases.

1 files changed, 92 insertions, 17 deletions

diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs
index 768c569..0fe277f 100644
--- a/src/Language/Fiddle/Compiler.hs
+++ b/src/Language/Fiddle/Compiler.hs
@@ -1,6 +1,24 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-- Compilation monad. Has diagnostics. Optionally produces a value.
+-- newtype Compile s a = Compile (s -> (s, [Diagnostic], Maybe a))
+-- Runs a sub-compilation routine with the given state, but discards the
+-- resulting state in favor of the original state.
+-- mapMaybeT (mapRWS (\(a, _, w) -> (a, s', w))) mtrws
+-- Saves the state, runs the routine, then restores the state.
+-- 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.
+{-# LANGUAGE RankNTypes #-}
+
 module Language.Fiddle.Compiler where
 
 import Control.Monad (when)
+import Control.Monad.Identity (Identity)
 import Control.Monad.RWS (RWS, RWST, evalRWS, mapRWS, runRWS)
 import Control.Monad.State
 import Control.Monad.Trans.Maybe
@@ -8,18 +26,15 @@ import Control.Monad.Writer
 import Data.Default
 import Language.Fiddle.Ast
 import Language.Fiddle.Types
-import Text.Parsec (SourcePos, sourceColumn, sourceLine, sourceName)
 import System.IO (hPutStrLn, stderr)
+import Text.Parsec (SourcePos, sourceColumn, sourceLine, sourceName)
 
 data Level = Error | Warning | Info
 
 data Diagnostic = Diagnostic Level String SourceSpan
 
--- Compilation monad. Has diagnostics. Optionally produces a value.
--- newtype Compile s a = Compile (s -> (s, [Diagnostic], Maybe a))
-
 newtype Compile s a = Compile (MaybeT (RWS () [Diagnostic] s) a)
-  deriving (Functor, Applicative, Monad)
+  deriving newtype (Functor, Applicative, Monad)
 
 compilationFailure :: Compile s a
 compilationFailure = Compile $ MaybeT (return Nothing)
@@ -34,29 +49,17 @@ instance MonadState s (Compile s) where
   put s = Compile $ put s
   state fn = Compile $ state fn
 
--- 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 (s', a)
 subCompile s' (Compile mtrws) = Compile $ do
   let (a, s, w) = runRWS (runMaybeT mtrws) () s'
   tell w
   MaybeT $ return $ fmap (s,) a
 
--- mapMaybeT (mapRWS (\(a, _, w) -> (a, s', w))) mtrws
-
--- Saves the state, runs the routine, then restores the state.
 pushState :: Compile s a -> Compile s a
 pushState cp = do
   s <- get
   snd <$> 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 = do
   let (a, _, w) = runRWS (runMaybeT fn) () initState in (w, a)
@@ -104,3 +107,75 @@ fromMayberOrFail sourceSpan err Nothing = do
   tell [Diagnostic Error err sourceSpan]
   compilationFailure
 fromMayberOrFail _ _ (Just a) = return a
+
+-- | '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
+-- 'FiddleUnit' from the current stage to the next.
+data CompilationPhase stageFrom stageTo where
+  CompilationPhase ::
+    forall privateState stageFrom stageTo.
+    (CompilationStage stageFrom) =>
+    { -- | 'ioAction' is an IO operation that runs after the ast is parsed. It
+      -- takes the parsed 'FiddleUnit' and performs some side effect
+      -- returning a private state that is passed to 'nextStage'. This is the
+      -- only time a side effect may be performed.
+      ioAction ::
+        FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) ->
+        IO 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
+      -- potentially updated 'FiddleUnit' in the compilation pipeline.
+      nextStage ::
+        privateState ->
+        FiddleUnit
+          stageFrom
+          (StageFunctor stageFrom)
+          (StageAnnotation stageFrom) ->
+        Compile
+          ()
+          ( FiddleUnit
+              stageTo
+              (StageFunctor stageTo)
+              (StageAnnotation stageTo)
+          )
+    } ->
+    CompilationPhase stageFrom stageTo
+
+-- | 'thenPhase' composes two 'CompilationPhase' stages into a single pipeline
+-- phase. It combines their IO actions and applies each stage in sequence.
+thenPhase ::
+  CompilationPhase stage1 stage2 ->
+  CompilationPhase stage2 stage3 ->
+  CompilationPhase stage1 stage3
+thenPhase
+  (CompilationPhase ioAction1 compile1)
+  (CompilationPhase ioAction2 compile2) =
+    CompilationPhase
+      (\unit -> (,) <$> ioAction1 unit <*> ioAction2 unit)
+      ( \(s1, s2) firstStage -> do
+          secondStage <- compile1 s1 firstStage
+          compile2 s2 secondStage
+      )
+
+-- | Infix operator for 'thenPhase' to chain compilation phases.
+(>>>) :: CompilationPhase stage1 stage2 -> CompilationPhase stage2 stage3 -> CompilationPhase stage1 stage3
+(>>>) = thenPhase
+
+-- | 'execCompilationPipeline' executes a full compilation pipeline starting
+-- from the 'Parsed' phase. It performs the IO action of the first phase and
+-- then invokes the compilation function for the remaining stages. It returns
+-- a tuple containing diagnostics and an optional final 'FiddleUnit'.
+execCompilationPipeline ::
+  CompilationPhase Parsed s' ->
+  FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) ->
+  IO
+    ( [Diagnostic],
+      Maybe
+        ( FiddleUnit s' (StageFunctor s') (StageAnnotation s')
+        )
+    )
+execCompilationPipeline (CompilationPhase ioAction rest) ast = do
+  s <- ioAction ast
+  return $ compile_ $ rest s ast