summaryrefslogtreecommitdiff
path: root/src/Language/Fiddle/Compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Fiddle/Compiler')
-rw-r--r--src/Language/Fiddle/Compiler/ConsistencyCheck.hs134
-rw-r--r--src/Language/Fiddle/Compiler/Expansion.hs6
-rw-r--r--src/Language/Fiddle/Compiler/ImportResolution.hs163
3 files changed, 258 insertions, 45 deletions
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 908db52..abfbb9b 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -23,7 +23,7 @@ import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Void
@@ -33,8 +33,8 @@ import GHC.TypeLits
import Language.Fiddle.Ast
import Language.Fiddle.Compiler
import Language.Fiddle.Internal.Scopes
-import Language.Fiddle.Internal.UnitInterface
-import Language.Fiddle.Types (Commented (unCommented), SourceSpan)
+import Language.Fiddle.Internal.UnitInterface as UnitInterface
+import Language.Fiddle.Types (Comment (DocComment), Commented (Commented, unCommented), SourceSpan)
import Text.Printf (printf)
import Prelude hiding (unzip)
@@ -57,14 +57,14 @@ type SizeBytes = Word32
consistencyCheckPhase ::
CompilationPhase Expanded Checked
consistencyCheckPhase =
- CompilationPhase (pure ()) (\_ _ -> return ()) (\_ _ -> checkConsistency)
+ CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> checkConsistency)
checkConsistency ::
FiddleUnit Expanded I Annot ->
Compile () (FiddleUnit Checked I Annot)
checkConsistency =
fmap snd
- . subCompile (GlobalState mempty mempty)
+ . subCompile (GlobalState mempty mempty mempty)
. advanceStage (LocalState mempty)
instance CompilationStage Checked where
@@ -81,7 +81,11 @@ instance CompilationStage Expanded where
type StageFunctor Expanded = Identity
type StageAnnotation Expanded = Commented SourceSpan
-instance AdvanceStage Expanded FiddleUnit
+instance AdvanceStage Expanded FiddleUnit where
+ advanceStage localState (FiddleUnit _ decls a) = do
+ decls' <- mapM (advanceStage localState) decls
+ intf <- gets unitInterface
+ return $ FiddleUnit intf decls' a
-- advanceStage localState (FiddleUnit decls _ annot) = do
@@ -107,7 +111,41 @@ deriving instance AdvanceStage Expanded EnumConstantDecl
deriving instance AdvanceStage Expanded PackageBody
-deriving instance AdvanceStage Expanded ImportStatement
+instance AdvanceStage Expanded ImportStatement where
+ modifyState
+ ( ImportStatement
+ { importInterface =
+ ( UnitInterface
+ { rootScope = unitScope,
+ dependencies = importDependencies
+ }
+ )
+ }
+ )
+ ls = do
+ modify'
+ ( \s@GlobalState
+ { globalScope = globalScope,
+ unitInterface = unitInterface
+ } ->
+ s
+ { globalScope =
+ unitInterfaceScopeToGlobalScope unitScope <> globalScope,
+ unitInterface =
+ unitInterface
+ { dependencies =
+ importDependencies ++ dependencies unitInterface
+ }
+ }
+ )
+ return ls
+ where
+ unitInterfaceScopeToGlobalScope =
+ fmap
+ ( \(Annotated _ _ exportedValue) -> case exportedValue of
+ ExportedBitsType sz -> Left sz
+ ExportedObjType sz -> Right sz
+ )
deriving instance (AdvanceStage Expanded t) => AdvanceStage Expanded (Directed t)
@@ -119,9 +157,9 @@ instance AdvanceStage Expanded ObjTypeBody where
instance AdvanceStage Expanded FiddleDecl where
modifyState t s = case t of
- (BitsDecl id typ a) -> do
+ (BitsDecl id typ annotation) -> do
typeSize <- getTypeSize typ
- insertTypeSize s id typeSize
+ insertTypeSize annotation s id typeSize
return s
(PackageDecl n _ _) -> do
let strs = nameToList n
@@ -139,6 +177,22 @@ instance AdvanceStage Expanded FiddleDecl where
}
_ -> return s
+ customAdvanceStage t (LocalState scopePath) = case t of
+ (ObjTypeDecl ident (Identity body) annot) -> do
+ (body', size) <- objTypeBodyToStage3 (LocalState scopePath) body 0
+
+ let fullName =
+ NonEmpty.prependList
+ (currentScope scopePath)
+ (NonEmpty.singleton (Text.unpack (identifierName ident)))
+
+ ui <- gets unitInterface
+ let ui' = insertIntoUnitInterface fullName ui annot (ExportedObjType size)
+ modify' $ \gs -> gs {unitInterface = ui'}
+
+ return $ Just $ ObjTypeDecl ident (Identity body') annot
+ _ -> return Nothing
+
nameToList :: Name f a -> [String]
nameToList (Name idents _) = map (\(Identifier (Text.unpack -> s) _) -> s) (toList idents)
@@ -444,9 +498,9 @@ lookupTypeSize (LocalState scopePath) (Name idents a) = do
case results of
-- Successfully resolved to a unique size
- [(_, Right sz)] -> return sz
+ [(_, Left sz)] -> return sz
-- Multiple ambiguous results found
- matches@(_ : _) -> do
+ matches@(_ : _ : _) -> do
-- Generate a list of ambiguous paths for error reporting
let ambiguousPaths =
map
@@ -467,7 +521,7 @@ lookupTypeSize (LocalState scopePath) (Name idents a) = do
compilationFailure
-- No matches found
- _ -> do
+ [] -> do
tell
[ Diagnostic
Error
@@ -528,23 +582,57 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
diagnosticError :: String -> Annot -> Compile a ()
diagnosticError str a = tell [Diagnostic Error str (unCommented a)]
+diagnosticInfo :: String -> Annot -> Compile a ()
+diagnosticInfo str a = tell [Diagnostic Info str (unCommented a)]
+
+insertIntoUnitInterface path ui (Commented comments srcspan) val =
+ let docComments =
+ mconcat
+ ( mapMaybe
+ ( \com -> do
+ (DocComment txt) <- Just com
+ return txt
+ )
+ comments
+ )
+ in ui
+ { rootScope =
+ insertScope path (Annotated srcspan docComments val) (rootScope ui)
+ }
+
insertTypeSize ::
+ Annot ->
LocalState ->
Identifier f Annot ->
SizeBits ->
Compile GlobalState ()
-insertTypeSize (LocalState scopePath) (Identifier s annot) size = do
+insertTypeSize annot (LocalState scopePath) (Identifier s idannot) size = do
modifyM $
- \state@GlobalState {globalScope = globalScope} ->
- let fullName =
- NonEmpty.prependList
- (currentScope scopePath)
- (NonEmpty.singleton (Text.unpack s))
- in case upsertScope fullName (Right size) globalScope of
- (Just _, _) -> do
- diagnosticError (printf "Duplicate type %s" s) annot
- compilationFailure
- (Nothing, n) -> return $ state {globalScope = n}
+ \state@GlobalState
+ { globalScope = globalScope,
+ unitInterface = unitInterface
+ } ->
+ let fullName =
+ NonEmpty.prependList
+ (currentScope scopePath)
+ (NonEmpty.singleton (Text.unpack s))
+ in case upsertScope fullName (Left size) globalScope of
+ (Just _, _) -> do
+ diagnosticError (printf "Duplicate type %s" s) idannot
+
+ compilationFailure
+ (Nothing, n) ->
+ let unitInterface' =
+ insertIntoUnitInterface
+ fullName
+ unitInterface
+ annot
+ (ExportedBitsType size)
+ in return $
+ state
+ { globalScope = n,
+ unitInterface = unitInterface'
+ }
where
modifyM fn = do
s <- get
diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs
index 7201686..1e8fbae 100644
--- a/src/Language/Fiddle/Compiler/Expansion.hs
+++ b/src/Language/Fiddle/Compiler/Expansion.hs
@@ -39,7 +39,7 @@ expandAst :: FiddleUnit CurrentStage I Annot -> Compile () (FiddleUnit Expanded
expandAst = fmap snd . subCompile (State [] []) . advanceStage (Path mempty)
expansionPhase :: CompilationPhase CurrentStage Expanded
-expansionPhase = CompilationPhase (pure ()) (\_ _ -> return ()) (\_ _ -> expandAst)
+expansionPhase = CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> expandAst)
-- Shorthand for Identity
type I = Identity
@@ -108,8 +108,8 @@ instance AdvanceStage CurrentStage FiddleDecl where
_ -> id
instance AdvanceStage CurrentStage FiddleUnit where
- advanceStage path (FiddleUnit decls a) =
- FiddleUnit <$> reconfigureFiddleDecls path decls <*> pure a
+ advanceStage path (FiddleUnit _ decls a) =
+ FiddleUnit () <$> reconfigureFiddleDecls path decls <*> pure a
instance AdvanceStage CurrentStage Expression where
advanceStage _ = \case
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
generated by cgit (git 2.34.1) at 2025-07-06 21:44:34 +0000