From e33f7c76b5258aae8de40d7361a49e56d82d9653 Mon Sep 17 00:00:00 2001 From: Joshua Grosso Date: Sun, 17 Nov 2019 20:35:30 -0800 Subject: [PATCH] [WIP] Pass the backend as a regular function parameter instead of using `Sem.Reader` While wiring everything up, Polysemy became very, very unhappy. I spent some time trying to figure out what I was doing wrong, but with no luck. Eventually, I ended up removing `Sem.Reader (Backend backendEffs)` altogether in favor of just passing `Backend backendEffs` around as a parameter. I've since been running into what I think is a variation of https://github.com/polysemy-research/polysemy/issues/280 (which I opened yesterday after finding an MVCE). --- src/Axel/Haskell/File.hs | 42 ++--- src/Axel/Haskell/Project.hs | 30 ++-- src/Axel/Macros.hs | 169 ++++++++---------- test/Axel/Test/Haskell/ErrorSpec.hs | 4 +- .../Test/Transpilation/TranspilationSpec.hs | 4 +- 5 files changed, 122 insertions(+), 127 deletions(-) diff --git a/src/Axel/Haskell/File.hs b/src/Axel/Haskell/File.hs index de69cf3..bff1745 100644 --- a/src/Axel/Haskell/File.hs +++ b/src/Axel/Haskell/File.hs @@ -23,7 +23,7 @@ import qualified Axel.Eff.Resource as Effs (Resource) import qualified Axel.Eff.Restartable as Effs (Restartable) import Axel.Haskell.Convert (convertFile) import Axel.Macros - ( HaskellBackendEffs + ( Backend , handleFunctionApplication , haskellBackend , processProgram @@ -96,27 +96,27 @@ readModuleInfo axelFiles = do pure $ M.fromList $ catMaybes modules transpileSource :: - forall effs fileExpanderEffs funAppExpanderEffs. + forall effs fileExpanderEffs funAppExpanderEffs backendEffs. ( fileExpanderEffs ~ '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] , funAppExpanderEffs ~ (Sem.Reader FilePath ': Effs.Restartable SM.Expression ': Sem.State [SMStatement] ': fileExpanderEffs) , Sem.Members '[ Sem.Error Error, Effs.Ghci, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] effs , Sem.Members fileExpanderEffs effs + , Sem.Members backendEffs effs ) - => FilePath + => Backend backendEffs + -> FilePath -> Text -> Sem.Sem effs SM.Output -transpileSource filePath source = +transpileSource backend filePath source = toHaskell . statementsToProgram <$> - Sem.runReader - haskellBackend - (parseSource (Just filePath) source >>= - processProgram - @fileExpanderEffs - @funAppExpanderEffs - @HaskellBackendEffs - handleFunctionApplication - (void . transpileFileInPlace) - filePath) + (parseSource (Just filePath) source >>= + processProgram + @fileExpanderEffs + @funAppExpanderEffs + backend + handleFunctionApplication + (\backend -> void . transpileFileInPlace backend) + filePath) convertFileInPlace :: (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error, Effs.FileSystem] effs) @@ -129,28 +129,30 @@ convertFileInPlace path = do transpileFile :: (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] effs) - => FilePath + => Backend backendEffs + -> FilePath -> FilePath -> Sem.Sem effs () -transpileFile path newPath = do +transpileFile backend path newPath = do fileContents <- FS.readFile path - newContents <- transpileSource path fileContents + newContents <- transpileSource backend path fileContents putStrLn $ op FilePath path <> " => " <> op FilePath newPath FS.writeFile newPath (SM.raw newContents) Sem.modify $ M.adjust (_2 ?~ newContents) path transpileFileInPlace :: (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] effs) - => FilePath + => Backend backendEffs + -> FilePath -> Sem.Sem effs FilePath -transpileFileInPlace path = do +transpileFileInPlace backend path = do moduleInfo <- Sem.gets $ M.lookup path let alreadyCompiled = case moduleInfo of Just (_, Just _) -> True _ -> False let newPath = replaceExtension path "hs" - unless alreadyCompiled $ transpileFile path newPath + unless alreadyCompiled $ transpileFile backend path newPath pure newPath formatFileInPlace :: diff --git a/src/Axel/Haskell/Project.hs b/src/Axel/Haskell/Project.hs index c093302..2452584 100644 --- a/src/Axel/Haskell/Project.hs +++ b/src/Axel/Haskell/Project.hs @@ -72,8 +72,8 @@ newProject projectName = do ] data ProjectFileType - = Axel - | Backend + = AxelFile + | BackendFile getProjectFiles :: (Sem.Member Effs.FileSystem effs) @@ -86,34 +86,38 @@ getProjectFiles fileType = do [FilePath "app", FilePath "src", FilePath "test"] let ext = case fileType of - Axel -> ".axel" - Backend -> ".hs" + AxelFile -> ".axel" + BackendFile -> ".hs" pure $ filter (\filePath -> ext `T.isSuffixOf` op FilePath filePath) files transpileProject :: (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource] effs) - => Sem.Sem effs ModuleInfo -transpileProject = + => Backend backendEffs + -> Sem.Sem effs ModuleInfo +transpileProject backend = Ghci.withGhci $ do - axelFiles <- getProjectFiles Axel + axelFiles <- getProjectFiles AxelFile initialModuleInfo <- readModuleInfo axelFiles (moduleInfo, _) <- - Sem.runState initialModuleInfo $ mapM transpileFileInPlace axelFiles + Sem.runState initialModuleInfo $ + mapM (transpileFileInPlace backend) axelFiles pure moduleInfo buildProject :: (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource] effs) - => Sem.Sem effs () -buildProject = do + => Backend backendEffs + -> Sem.Sem effs () +buildProject backend = do void $ passthroughProcess "hpack" projectPath <- getCurrentDirectory - transpiledFiles <- transpileProject + transpiledFiles <- transpileProject backend Cabal.buildProject transpiledFiles projectPath convertProject :: (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error, Effs.FileSystem, Effs.Process] effs) => Sem.Sem effs () -convertProject = getProjectFiles Backend >>= void . traverse convertFileInPlace +convertProject = + getProjectFiles BackendFile >>= void . traverse convertFileInPlace runProject :: (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Process] effs) @@ -123,4 +127,4 @@ runProject = getCurrentDirectory >>= Cabal.runProject formatProject :: (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error] effs) => Sem.Sem effs () -formatProject = getProjectFiles Axel >>= void . traverse formatFileInPlace +formatProject = getProjectFiles AxelFile >>= void . traverse formatFileInPlace diff --git a/src/Axel/Macros.hs b/src/Axel/Macros.hs index 557aba6..a8e1768 100644 --- a/src/Axel/Macros.hs +++ b/src/Axel/Macros.hs @@ -242,25 +242,25 @@ type FileExpander effs = Effs.Callback effs FileExpanderArgs () processProgram :: forall fileExpanderEffs funAppExpanderEffs backendEffs effs innerEffs. ( innerEffs ~ (Sem.State [SMStatement] ': Effs.Restartable SM.Expression ': Sem.Reader FilePath ': effs) - , Sem.Members '[ Sem.Error Error, Effs.Ghci, Sem.Reader (Backend backendEffs), Sem.Reader Ghcid.Ghci, Sem.State ModuleInfo] effs + , Sem.Members '[ Sem.Error Error, Effs.Ghci, Sem.Reader Ghcid.Ghci, Sem.State ModuleInfo] effs , Sem.Members fileExpanderEffs innerEffs , Sem.Members funAppExpanderEffs innerEffs , Sem.Members backendEffs effs ) - => FunctionApplicationExpander funAppExpanderEffs - -> FileExpander fileExpanderEffs + => Backend backendEffs + -> (Backend backendEffs -> FunctionApplicationExpander funAppExpanderEffs) + -> (Backend backendEffs -> FileExpander fileExpanderEffs) -> FilePath -> SM.Expression -> Sem.Sem effs [SMStatement] -processProgram expandFunApp expandFile filePath program = do - backend <- Sem.ask @(Backend backendEffs) +processProgram backend expandFunApp expandFile filePath program = do newProgramExpr <- Sem.runReader filePath $ expandProgramExpr @funAppExpanderEffs @fileExpanderEffs - expandFunApp - expandFile + (expandFunApp backend) + (expandFile backend) program newStmts <- mapM @@ -268,17 +268,10 @@ processProgram expandFunApp expandFile filePath program = do (unwrapCompoundExpressions newProgramExpr) withAstImports <- insertImports filePath (mkAutogeneratedImports backend filePath) newStmts - finalizeProgram @backendEffs withAstImports + pure $ finalizeProgram backend withAstImports -finalizeProgram :: - forall backendEffs effs. - ( Sem.Member (Sem.Reader (Backend backendEffs)) effs - , Sem.Members backendEffs effs - ) - => [SMStatement] - -> Sem.Sem effs [SMStatement] -finalizeProgram stmts = do - backend <- Sem.ask +finalizeProgram :: Backend backendEffs -> [SMStatement] -> [SMStatement] +finalizeProgram backend stmts = do let expandQuotes = bottomUpFmapSplicing (\case @@ -298,12 +291,11 @@ finalizeProgram stmts = do toTopLevelStmts = map (unsafeNormalize normalizeStatement) . unwrapCompoundExpressions toProgramExpr = wrapCompoundExpressions . map denormalizeStatement - macroTySigs <- typeMacroDefinitions hygenicMacroDefs - pure $ toTopLevelStmts $ makeSymbolSubstitutions $ expandQuotes $ - toProgramExpr $ - nonMacroDefs <> - map SMacroDefinition hygenicMacroDefs <> - macroTySigs + macroTySigs = typeMacroDefinitions backend hygenicMacroDefs + in toTopLevelStmts $ makeSymbolSubstitutions $ expandQuotes $ toProgramExpr $ + nonMacroDefs <> + map SMacroDefinition hygenicMacroDefs <> + macroTySigs isMacroImported :: (Sem.Member (Sem.State [SMStatement]) effs) @@ -461,20 +453,21 @@ addStatementToMacroEnvironment expandFile newExpr = do -- | If a function application is a macro call, expand it. handleFunctionApplication :: forall backendEffs effs. - ( Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Sem.State ModuleInfo, Sem.Reader (Backend backendEffs), Sem.Reader Ghcid.Ghci, Sem.Reader FilePath, Sem.State [SMStatement]] effs + ( Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Sem.State ModuleInfo, Sem.Reader Ghcid.Ghci, Sem.Reader FilePath, Sem.State [SMStatement]] effs , Sem.Members backendEffs (Sem.Reader ExpansionId ': effs) ) - => SM.Expression + => Backend backendEffs + -> SM.Expression -> Sem.Sem effs (Maybe [SM.Expression]) -handleFunctionApplication fnApp@(Parse.SExpression ann (Parse.Symbol _ functionName:args)) = do +handleFunctionApplication backend fnApp@(Parse.SExpression ann (Parse.Symbol _ functionName:args)) = do shouldExpand <- isMacroCall $ T.pack functionName if shouldExpand then Just <$> withExpansionId fnApp - (expandMacroApplication @backendEffs ann (T.pack functionName) args) + (expandMacroApplication backend ann (T.pack functionName) args) else pure Nothing -handleFunctionApplication _ = pure Nothing +handleFunctionApplication _ _ = pure Nothing isMacroCall :: (Sem.Member (Sem.State [SMStatement]) effs) @@ -535,15 +528,15 @@ mkScaffoldModuleName (ExpansionId expansionId) = generateMacroProgram :: forall backendEffs effs. - ( Sem.Members '[ Sem.Error Error, Effs.FileSystem, Sem.Reader ExpansionId, Sem.Reader (Backend backendEffs), Sem.State [SMStatement]] effs + ( Sem.Members '[ Sem.Error Error, Effs.FileSystem, Sem.Reader ExpansionId, Sem.State [SMStatement]] effs , Sem.Members backendEffs effs ) - => FilePath + => Backend backendEffs + -> FilePath -> Identifier -> [SM.Expression] -> Sem.Sem effs (SM.Output, SM.Output) -generateMacroProgram filePath' oldMacroName args = do - backend <- Sem.ask @(Backend backendEffs) +generateMacroProgram backend filePath' oldMacroName args = do macroDefAndEnvModuleName <- Sem.asks mkMacroDefAndEnvModuleName scaffoldModuleName <- Sem.asks mkScaffoldModuleName let newMacroName = hygenisizeMacroName oldMacroName @@ -572,7 +565,7 @@ generateMacroProgram filePath' oldMacroName args = do programStmts <- insertImports filePath' header $ replaceModuleDecl moduleDecl $ auxEnv <> footer - finalizeProgram @backendEffs programStmts + pure $ finalizeProgram backend programStmts pure $ uncurry ((,) `on` toHaskell . statementsToProgram) @@ -588,14 +581,9 @@ generateMacroProgram filePath' oldMacroName args = do else newModuleDecl : stmts typeMacroDefinitions :: - ( Sem.Member (Sem.Reader (Backend backendEffs)) effs - , Sem.Members backendEffs effs - ) - => [MacroDefinition ann] - -> Sem.Sem effs [SMStatement] -typeMacroDefinitions macroDefs = do - backend <- Sem.ask - pure $ map (mkMacroTypeSignature backend) $ getMacroNames macroDefs + Backend backendEffs -> [MacroDefinition ann] -> [SMStatement] +typeMacroDefinitions backend macroDefs = + map (mkMacroTypeSignature backend) $ getMacroNames macroDefs where getMacroNames = nub . map (^. functionDefinition . name) @@ -619,19 +607,20 @@ withExpansionId originalCall x = expandMacroApplication :: forall backendEffs effs. - ( Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Sem.Reader ExpansionId, Sem.Reader Ghcid.Ghci, Sem.Reader (Backend backendEffs), Sem.Reader FilePath, Sem.State [SMStatement]] effs + ( Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Sem.Reader ExpansionId, Sem.Reader Ghcid.Ghci, Sem.Reader FilePath, Sem.State [SMStatement]] effs , Sem.Members backendEffs effs ) - => SourceMetadata + => Backend backendEffs + -> SourceMetadata -> Identifier -> [SM.Expression] -> Sem.Sem effs [SM.Expression] -expandMacroApplication originalAnn macroName args = do +expandMacroApplication backend originalAnn macroName args = do logStrLn $ "Expanding: " <> toAxel (losslyReconstructMacroCall macroName args) filePath' <- Sem.ask @FilePath - macroProgram <- generateMacroProgram @backendEffs filePath' macroName args + macroProgram <- generateMacroProgram backend filePath' macroName args (tempFilePath, newSource) <- - uncurry (evalMacro @backendEffs originalAnn macroName args) macroProgram + uncurry (evalMacro backend originalAnn macroName args) macroProgram logStrLn $ "Result: " <> newSource <> "\n\n" parseMultiple (Just tempFilePath) newSource @@ -641,17 +630,17 @@ isMacroDefinitionStatement _ = False evalMacro :: forall backendEffs effs. - ( Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Sem.Reader Ghcid.Ghci, Sem.Reader FilePath, Sem.Reader ExpansionId, Sem.Reader (Backend backendEffs)] effs + ( Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Sem.Reader Ghcid.Ghci, Sem.Reader FilePath, Sem.Reader ExpansionId] effs , Sem.Members backendEffs effs ) - => SourceMetadata + => Backend backendEffs + -> SourceMetadata -> Identifier -> [SM.Expression] -> SM.Output -> SM.Output -> Sem.Sem effs (FilePath, Text) -evalMacro originalCallAnn macroName args scaffoldProgram macroDefAndEnvProgram = do - backend <- Sem.ask @(Backend backendEffs) +evalMacro backend originalCallAnn macroName args scaffoldProgram macroDefAndEnvProgram = do macroDefAndEnvModuleName <- Sem.asks mkMacroDefAndEnvModuleName scaffoldModuleName <- Sem.asks mkScaffoldModuleName tempDir <- getTempDirectory @@ -675,15 +664,15 @@ evalMacro originalCallAnn macroName args scaffoldProgram macroDefAndEnvProgram = if wasCompileSuccessful backend compileResult then do result <- runFile backend scaffoldFileName - expansionRecord <- - generateExpansionRecord - @backendEffs - originalCallAnn - macroName - args - result - scaffoldFileName - macroDefAndEnvFileName + let expansionRecord = + generateExpansionRecord + backend + originalCallAnn + macroName + args + result + scaffoldFileName + macroDefAndEnvFileName FS.writeFile resultFile expansionRecord if wasRunSuccessful backend result then throwMacroError result @@ -707,44 +696,40 @@ evalMacro originalCallAnn macroName args scaffoldProgram macroDefAndEnvProgram = msg generateExpansionRecord :: - ( Sem.Member (Sem.Reader (Backend backendEffs)) effs - , Sem.Members backendEffs effs - ) - => SourceMetadata + Backend backendEffs + -> SourceMetadata -> Identifier -> [SM.Expression] -> Text -> FilePath -> FilePath - -> Sem.Sem effs Text -generateExpansionRecord originalAnn macroName args result scaffoldFilePath macroDefAndEnvFilePath = do - backend <- Sem.ask - pure $ - T.unlines - [ result - , mkComment - backend - "This file is an autogenerated record of a macro call and expansion." - , mkComment - backend - "It is (likely) not a valid Axel program, so you probably don't want to run it directly." - , "" - , mkComment - backend - "The beginning of this file contains the result of the macro invocation at " <> - locationHint <> - ":" - , toAxel (losslyReconstructMacroCall macroName args) - , "" - , mkComment backend $ "The macro call itself is transpiled in " <> - op FilePath (takeFileName scaffoldFilePath) <> - "." - , "" - , mkComment backend $ - "To see the (transpiled) modules, definitions, extensions, etc. visible during the expansion, check " <> - op FilePath (takeFileName macroDefAndEnvFilePath) <> - "." - ] + -> Text +generateExpansionRecord backend originalAnn macroName args result scaffoldFilePath macroDefAndEnvFilePath = + T.unlines + [ result + , mkComment + backend + "This file is an autogenerated record of a macro call and expansion." + , mkComment + backend + "It is (likely) not a valid Axel program, so you probably don't want to run it directly." + , "" + , mkComment + backend + "The beginning of this file contains the result of the macro invocation at " <> + locationHint <> + ":" + , toAxel (losslyReconstructMacroCall macroName args) + , "" + , mkComment backend $ "The macro call itself is transpiled in " <> + op FilePath (takeFileName scaffoldFilePath) <> + "." + , "" + , mkComment backend $ + "To see the (transpiled) modules, definitions, extensions, etc. visible during the expansion, check " <> + op FilePath (takeFileName macroDefAndEnvFilePath) <> + "." + ] where locationHint = case originalAnn of diff --git a/test/Axel/Test/Haskell/ErrorSpec.hs b/test/Axel/Test/Haskell/ErrorSpec.hs index fa2493d..cdc0fb6 100644 --- a/test/Axel/Test/Haskell/ErrorSpec.hs +++ b/test/Axel/Test/Haskell/ErrorSpec.hs @@ -14,6 +14,7 @@ import qualified Axel.Eff.Random as Effs import qualified Axel.Eff.Resource as Effs import qualified Axel.Eff.Time as Effs import Axel.Haskell.File +import Axel.Macros (haskellBackend) import Axel.Sourcemap as SM import Axel.Utils.FilePath import Axel.Utils.Text @@ -55,7 +56,8 @@ test_errors_golden = do output <- runApp $ Sem.evalState (M.empty :: ModuleInfo) $ - Ghci.withGhci $ transpileSource (takeBaseName axelFile) axelSource + Ghci.withGhci $ + transpileSource haskellBackend (takeBaseName axelFile) axelSource case output of Right _ -> error $ diff --git a/test/Axel/Test/Transpilation/TranspilationSpec.hs b/test/Axel/Test/Transpilation/TranspilationSpec.hs index a06f216..4c2a374 100644 --- a/test/Axel/Test/Transpilation/TranspilationSpec.hs +++ b/test/Axel/Test/Transpilation/TranspilationSpec.hs @@ -14,6 +14,7 @@ import qualified Axel.Eff.Random as Effs import qualified Axel.Eff.Resource as Effs import qualified Axel.Eff.Time as Effs import Axel.Haskell.File +import Axel.Macros (haskellBackend) import Axel.Sourcemap as SM import Axel.Utils.FilePath import Axel.Utils.Text @@ -55,7 +56,8 @@ test_transpilation_golden = do output <- runApp $ Sem.evalState (M.empty :: ModuleInfo) $ - Ghci.withGhci $ transpileSource (takeBaseName axelFile) axelSource + Ghci.withGhci $ + transpileSource haskellBackend (takeBaseName axelFile) axelSource let newSource = encodeUtf8Lazy $ SM.raw output pure $ newSource <> "\n" pure $