1 files changed, 144 insertions, 19 deletions
diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index 47eec72..4f076b8 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -8,12 +8,20 @@ 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.Identity (Identity)
-import Control.Monad.Writer.Lazy (MonadTrans (lift), MonadWriter (tell), WriterT (WriterT), execWriterT)
+import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
+import Control.Monad.Writer.Lazy (MonadTrans (lift), MonadWriter (tell), WriterT (WriterT, runWriterT), execWriterT)
+import Data.Aeson (decode, eitherDecode, encode)
+import qualified Data.ByteString.Lazy as BL
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as Text
+import Data.Tuple (swap)
 import Data.Typeable
 import Language.Fiddle.Ast
 import Language.Fiddle.Ast.FileInterface (ResolvedImport)
@@ -22,7 +30,9 @@ import Language.Fiddle.Compiler.Expansion
 import Language.Fiddle.Internal.UnitInterface
 import Language.Fiddle.Types
 import Options.Applicative
-import System.IO (hPutStrLn, stderr)
+import System.Directory
+import System.FilePath
+import System.IO
 import Text.Printf (printf)
 
 newtype Flags = Flags
@@ -42,9 +52,15 @@ parseFlags =
       )
 
 importResolutionPhase ::
+  ( FilePath ->
+    IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+  ) ->
+  ( TreeType FiddleUnit Parsed ->
+    IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+  ) ->
   CompilationPhase CurrentStage ImportsResolved
-importResolutionPhase =
-  CompilationPhase parseFlags getImportResolutionState resolveImports
+importResolutionPhase parseFile compileToChecked =
+  CompilationPhase parseFlags (getImportResolutionState parseFile compileToChecked) resolveImports
 
 type GlobalState = ()
 
@@ -54,11 +70,10 @@ type M = Compile GlobalState
 
 type Annot = Commented SourceSpan
 
-data ImportError = ImportError Text (Maybe SourceSpan)
-  deriving (Show)
+newtype ImportError = ImportError [Diagnostic]
 
 newtype ResolvedImports = ResolvedImports
-  { importMap :: Map Text (Either ImportError UnitInterface)
+  { importMap :: Map Text ([Diagnostic], Maybe UnitInterface)
   }
   deriving newtype (Semigroup, Monoid)
 
@@ -124,27 +139,45 @@ instance AdvanceStage CurrentStage ImportStatement where
       Nothing -> do
         diagnosticError "Failed to lookup imports (This is a bug)" a
         return empty
-      Just (Left err) -> do
-        diagnosticError (printf "Error in import %s: %s" path (show err)) a
-        return empty
-      Just (Right val) -> return val
+      Just (diags, val) -> do
+        tell diags
+        return $ fromMaybe empty val
 
     return $ ImportStatement path list v a
 
 getImportResolutionState ::
+  ( FilePath ->
+    IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+  ) ->
+  ( TreeType FiddleUnit Parsed ->
+    IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+  ) ->
   Flags ->
   FiddleUnit CurrentStage Identity Annot ->
-  IO ResolvedImports
-getImportResolutionState flags unit =
-  execWriterT $
-    walk doWalk unit ()
+  IO ([Diagnostic], Maybe ResolvedImports)
+getImportResolutionState parseFile compileToChecked flags unit = do
+  fmap
+    ( lookForFailures
+        . second Just
+    )
+    $ execWriterT
+    $ walk doWalk unit ()
   where
-    -- doWalk :: forall t'. (Walk t', Typeable t') => t' Identity Annot -> () -> WriterT ResolvedImports IO ()
+    doWalk :: forall t'. (Walk t', Typeable t') => t' Identity Annot -> () -> WriterT ([Diagnostic], ResolvedImports) IO ()
     doWalk u () =
       case () of
-        () | Just (ImportStatement {importPath = path}) <- castTS u -> do
-          lift $ hPutStrLn stderr $ "Import path: " ++ show path
-          (return () :: WriterT ResolvedImports IO ())
+        ()
+          | Just
+              (ImportStatement {importPath = path, importStatementAnnot = (unCommented -> a)}) <-
+              castTS u -> do
+              (diagnostics, unitInterface) <-
+                lift $
+                  ioGetImportInterface a (importDirectories flags) (Text.unpack path)
+
+              tell
+                ( [],
+                  ResolvedImports $ Map.singleton path (diagnostics, unitInterface)
+                )
         _ -> return ()
 
     castTS ::
@@ -156,3 +189,95 @@ getImportResolutionState flags unit =
       t' f a ->
       Maybe (t CurrentStage f a)
     castTS = cast
+
+    lookForFailures :: ([Diagnostic], Maybe a) -> ([Diagnostic], Maybe a)
+    lookForFailures (diags, a) = do
+      if any (\(Diagnostic e _ _) -> e == Error) diags
+        then (diags, Nothing)
+        else (diags, a)
+
+    ioGetImportInterface :: SourceSpan -> [FilePath] -> FilePath -> IO ([Diagnostic], Maybe UnitInterface)
+    ioGetImportInterface srcSpan imports fp = runCompl $ do
+      path <- findFileInImportPath srcSpan imports fp
+      let intf = interfaceFile path
+      valid <- lift2 $ interfaceFileValid path intf
+
+      let doFullCompile = do
+            parsed <- bump (parseFile path)
+            unitInterface <- addDependency path . fiddleUnitInterface <$> bump (compileToChecked parsed)
+            lift2 $ writeInterfaceFile intf unitInterface
+            return unitInterface
+
+      if valid
+        then do
+          e <- lift2 (readInterfaceFile intf)
+          case e of
+            Right val -> do
+              needFullRecompile <- lift2 $ checkNeedFullRecompile intf val
+              if needFullRecompile
+                then doFullCompile
+                else return val
+            Left err -> do
+              tell [Diagnostic Error err srcSpan]
+              MaybeT $ return Nothing
+        else doFullCompile
+
+    addDependency path unitInterface =
+      unitInterface {dependencies = path : dependencies unitInterface}
+
+    interfaceFile filePath = takeBaseName filePath <.> "fdi"
+
+    checkNeedFullRecompile intfFile (UnitInterface {dependencies = dependencies}) =
+      allM
+        ( \depfile -> do
+            timeDep <- getModificationTime depfile
+            timeIntf <- getModificationTime intfFile
+            return (timeIntf > timeDep)
+        )
+        dependencies
+
+    readInterfaceFile intfile =
+      eitherDecode . GZip.decompress <$> BL.readFile intfile
+
+    writeInterfaceFile intfile val =
+      BL.writeFile intfile $ GZip.compress (encode val)
+
+    interfaceFileValid :: FilePath -> FilePath -> IO Bool
+    interfaceFileValid originalPath intfPath = do
+      exists <- doesFileExist intfPath
+      if exists
+        then do
+          timeOrig <- getModificationTime originalPath
+          timeIntf <- getModificationTime intfPath
+          return (timeIntf > timeOrig)
+        else return False
+
+    findFileInImportPath :: SourceSpan -> [FilePath] -> FilePath -> Compl FilePath
+    findFileInImportPath sourceSpan paths path = do
+      realPaths <- lift2 $ filterM doesFileExist (map (++ ("/" ++ path)) paths)
+
+      case realPaths of
+        [] -> do
+          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 x = do
+  (diags, ma) <- lift2 x
+  lift $ tell diags
+  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)
+
+type Compl a = MaybeT (WriterT [Diagnostic] IO) a
+
+allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+allM _ [] = return True
+allM fn (a : as) = do
+  b <- fn a
+  if b then allM fn as else return False