diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -1,8 +1,11 @@ #+OPTIONS: num:nil toc:nil +#+STARTUP: inlineimages * Axel Haskell + Lisp + JVM/Node/... = Profit! See [[https://axellang.github.io]]. + #+CAPTION: Build Status + [[https://travis-ci.org/axellang/axel.svg?branch=master]] ** Code Style Use ~hindent~ to format code and ~hlint~ to catch errors. ** Running diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,32 +1,47 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} module Main where +import Prelude hiding (putStrLn) + +import Axel.Eff.Console (putStrLn) +import qualified Axel.Eff.Console as Effs (Console) +import qualified Axel.Eff.Console as Console (runEff) +import qualified Axel.Eff.FileSystem as FS (runEff) +import qualified Axel.Eff.FileSystem as Effs (FileSystem) +import qualified Axel.Eff.Process as Proc (runEff) +import qualified Axel.Eff.Process as Effs (Process) +import qualified Axel.Eff.Resource as Res (runEff) +import qualified Axel.Eff.Resource as Effs (Resource) import Axel.Error (Error) -import qualified Axel.Error as Error (toIO) +import qualified Axel.Error as Error (runEff) import Axel.Haskell.File (evalFile) import Axel.Haskell.Project (buildProject, runProject) -import Axel.Parse.Args (ModeCommand(File, Project), modeCommandParser) +import Axel.Haskell.Stack (axelStackageVersion) +import Axel.Parse.Args (Command(File, Project, Version), commandParser) -import Control.Monad.Except (ExceptT, MonadError) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Freer (Eff) +import qualified Control.Monad.Freer as Effs (runM) +import qualified Control.Monad.Freer.Error as Effs (Error) -import Options.Applicative (execParser, info, progDesc) +import Options.Applicative ((<**>), execParser, helper, info, progDesc) -newtype AppM a = AppM - { runAppM :: ExceptT Error IO a - } deriving (Functor, Applicative, Monad, MonadError Error, MonadIO) +type AppEffs + = Eff '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource, IO] -runAppM' :: AppM a -> IO a -runAppM' = Error.toIO . runAppM +runApp :: AppEffs a -> IO a +runApp = + Effs.runM . + Res.runEff . Proc.runEff . FS.runEff . Error.runEff . Console.runEff -app :: ModeCommand -> AppM () +app :: Command -> AppEffs () app (File filePath) = evalFile filePath app Project = buildProject >> runProject +app Version = putStrLn $ "Axel version " <> axelStackageVersion main :: IO () main = do modeCommand <- - execParser $ info modeCommandParser (progDesc "The command to run.") - runAppM' $ app modeCommand + execParser $ + info (commandParser <**> helper) (progDesc "The command to run.") + runApp $ app modeCommand diff --git a/axel.cabal b/axel.cabal --- a/axel.cabal +++ b/axel.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: bd98666bdad98615fa9b95dbfdbcf860ae5ad9fd5595b478e5f76d1390962147 +-- hash: 716ae6ec648d90a914b50e20a88b41dd9aee9dac2b091b5447034de826522e20 name: axel -version: 0.0.5 +version: 0.0.6 synopsis: The Axel programming language. description: Haskell's semantics, plus Lisp's macros. Meet Axel – a purely functional, extensible, and powerful programming language. category: Language, Lisp, Macros, Transpiler @@ -50,17 +50,16 @@ exposed-modules: Axel.AST Axel.Denormalize + Axel.Eff.Console + Axel.Eff.FileSystem + Axel.Eff.Process + Axel.Eff.Resource Axel.Error Axel.Haskell.File - Axel.Haskell.GHC Axel.Haskell.Prettify Axel.Haskell.Project Axel.Haskell.Stack Axel.Macros - Axel.Monad.Console - Axel.Monad.FileSystem - Axel.Monad.Process - Axel.Monad.Resource Axel.Normalize Axel.Parse Axel.Parse.Args @@ -81,20 +80,20 @@ , bytestring >=0.10.8 && <0.11 , directory >=1.3 && <1.4 , filepath >=1.4.1 && <1.5 + , freer-simple >=1.1.0.0 && <1.2 , haskell-src-exts >=1.20.2 && <1.21 , lens >=4.16.1 && <4.18 , lens-aeson >=1.0.2 && <1.1 - , mtl >=2.2.1 && <2.3 , optparse-applicative >=0.14.2 && <0.15 , parsec >=3.1.11 && <3.2 , process >=1.6.1 && <1.7 , regex-pcre >=0.94.4 && <0.95 + , singletons >=2.4 && <2.6 , strict >=0.3.2 && <0.4 , text >=1.2.2 && <1.3 - , transformers >=0.5.5 && <0.6 , typed-process >=0.2.2 && <0.3 , vector >=0.12.0 && <0.13 - , yaml >=0.8.31 && <0.10 + , yaml >=0.8.31 && <0.11 default-language: Haskell2010 executable axel-exe @@ -107,7 +106,7 @@ build-depends: axel , base >=4.11.1 && <4.12 - , mtl >=2.2.1 && <2.3 + , freer-simple >=1.1.0.0 && <1.2 , optparse-applicative >=0.14.2 && <0.15 default-language: Haskell2010 @@ -117,17 +116,16 @@ other-modules: Axel.Test.ASTGen Axel.Test.DenormalizeSpec + Axel.Test.Eff.ConsoleMock + Axel.Test.Eff.ConsoleSpec + Axel.Test.Eff.FileSystemMock + Axel.Test.Eff.FileSystemSpec + Axel.Test.Eff.ProcessMock + Axel.Test.Eff.ResourceMock + Axel.Test.Eff.ResourceSpec Axel.Test.File.FileSpec - Axel.Test.Haskell.GHCSpec Axel.Test.Haskell.StackSpec Axel.Test.MockUtils - Axel.Test.Monad.ConsoleMock - Axel.Test.Monad.ConsoleSpec - Axel.Test.Monad.FileSystemMock - Axel.Test.Monad.FileSystemSpec - Axel.Test.Monad.ProcessMock - Axel.Test.Monad.ResourceMock - Axel.Test.Monad.ResourceSpec Axel.Test.NormalizeSpec Axel.Test.Parse.ASTGen Axel.Test.ParseSpec @@ -140,9 +138,9 @@ , base >=4.11.1 && <4.12 , bytestring , filepath + , freer-simple >=1.1.0.0 && <1.2 , hedgehog , lens - , mtl >=2.2.1 && <2.3 , split , tasty , tasty-discover diff --git a/resources/autogenerated/macros/AST.hs b/resources/autogenerated/macros/AST.hs --- a/resources/autogenerated/macros/AST.hs +++ b/resources/autogenerated/macros/AST.hs @@ -6,6 +6,7 @@ module Axel.Parse.AST where import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +import Data.Semigroup ((<>)) import System.IO.Unsafe (unsafePerformIO) @@ -26,8 +27,8 @@ toAxel :: Expression -> String toAxel (LiteralChar x) = ['{', x, '}'] toAxel (LiteralInt x) = show x -toAxel (LiteralString xs) = "\"" ++ xs ++ "\"" -toAxel (SExpression xs) = "(" ++ unwords (map toAxel xs) ++ ")" +toAxel (LiteralString xs) = "\"" <> xs <> "\"" +toAxel (SExpression xs) = "(" <> unwords (map toAxel xs) <> ")" toAxel (Symbol x) = x -- ****************************** @@ -40,7 +41,7 @@ gensym :: IO Expression gensym = do suffix <- readIORef gensymCounter - let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" ++ show suffix + let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" <> show suffix modifyIORef gensymCounter succ pure $ Symbol identifier diff --git a/scripts/build.sh b/scripts/build.sh --- a/scripts/build.sh +++ b/scripts/build.sh @@ -6,4 +6,4 @@ cp src/Axel/Parse/AST.hs resources/autogenerated/macros/AST.hs echo "Macro header copied!" -stack build +stack build --fast diff --git a/src/Axel/AST.hs b/src/Axel/AST.hs --- a/src/Axel/AST.hs +++ b/src/Axel/AST.hs @@ -123,6 +123,12 @@ , _imports :: ImportSpecification } deriving (Eq, Show) +data TypeclassDefinition = TypeclassDefinition + { _name :: Expression + , _constraints :: [Expression] + , _signatures :: [TypeSignature] + } deriving (Eq, Show) + data TypeclassInstance = TypeclassInstance { _instanceName :: Expression , _definitions :: [FunctionDefinition] @@ -146,6 +152,7 @@ | ELambda Lambda | ELetBlock LetBlock | ELiteral Literal + | ERawExpression String deriving (Eq, Show) instance ToHaskell Expression where @@ -160,6 +167,7 @@ toHaskell (ELambda x) = toHaskell x toHaskell (ELetBlock x) = toHaskell x toHaskell (ELiteral x) = toHaskell x + toHaskell (ERawExpression x) = x data Literal = LChar Char @@ -180,8 +188,10 @@ | SModuleDeclaration Identifier | SPragma Pragma | SQualifiedImport QualifiedImport + | SRawStatement String | SRestrictedImport RestrictedImport | STopLevel TopLevel + | STypeclassDefinition TypeclassDefinition | STypeclassInstance TypeclassInstance | STypeSignature TypeSignature | STypeSynonym TypeSynonym @@ -196,8 +206,10 @@ toHaskell (SMacroDefinition x) = toHaskell x toHaskell (SModuleDeclaration x) = "module " <> x <> " where" toHaskell (SQualifiedImport x) = toHaskell x + toHaskell (SRawStatement x) = x toHaskell (SRestrictedImport x) = toHaskell x toHaskell (STopLevel xs) = toHaskell xs + toHaskell (STypeclassDefinition x) = toHaskell x toHaskell (STypeclassInstance x) = toHaskell x toHaskell (STypeSignature x) = toHaskell x toHaskell (STypeSynonym x) = toHaskell x @@ -227,6 +239,8 @@ makeFieldsNoPrefix ''TopLevel +makeFieldsNoPrefix ''TypeclassDefinition + makeFieldsNoPrefix ''TypeclassInstance makeFieldsNoPrefix ''TypeSignature @@ -322,6 +336,18 @@ toHaskell :: TopLevel -> String toHaskell topLevel = delimit Newlines $ map toHaskell (topLevel ^. statements) +instance ToHaskell TypeclassDefinition where + toHaskell :: TypeclassDefinition -> String + toHaskell typeclassDefinition = + "class " <> + surround + Parentheses + (delimit Commas (map toHaskell (typeclassDefinition ^. constraints))) <> + " => " <> + toHaskell (typeclassDefinition ^. name) <> + " where " <> + renderBlock (map toHaskell $ typeclassDefinition ^. signatures) + instance ToHaskell TypeclassInstance where toHaskell :: TypeclassInstance -> String toHaskell typeclassInstance = @@ -361,6 +387,7 @@ LChar _ -> x LInt _ -> x LString _ -> x + ERawExpression _ -> x topDownFmap :: (Expression -> Expression) -> Expression -> Expression topDownFmap f x = case f x of @@ -386,6 +413,7 @@ LChar _ -> x LInt _ -> x LString _ -> x + ERawExpression _ -> x bottomUpTraverse :: (Monad m) => (Expression -> m Expression) -> Expression -> m Expression bottomUpTraverse f x = @@ -420,3 +448,4 @@ LChar _ -> pure x LInt _ -> pure x LString _ -> pure x + ERawExpression _ -> pure x diff --git a/src/Axel/Denormalize.hs b/src/Axel/Denormalize.hs --- a/src/Axel/Denormalize.hs +++ b/src/Axel/Denormalize.hs @@ -2,20 +2,21 @@ import Axel.AST ( Expression(ECaseBlock, EEmptySExpression, EFunctionApplication, - EIdentifier, ELambda, ELetBlock, ELiteral) + EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression) , Import(ImportItem, ImportType) , ImportSpecification(ImportAll, ImportOnly) , Literal(LChar, LInt, LString) , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition, - SModuleDeclaration, SPragma, SQualifiedImport, SRestrictedImport, - STopLevel, STypeSignature, STypeSynonym, STypeclassInstance, - SUnrestrictedImport) + SModuleDeclaration, SPragma, SQualifiedImport, SRawStatement, + SRestrictedImport, STopLevel, STypeSignature, STypeSynonym, + STypeclassDefinition, STypeclassInstance, SUnrestrictedImport) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor) , alias , arguments , bindings , body + , constraints , constructors , definition , definitions @@ -28,6 +29,7 @@ , moduleName , name , pragmaSpecification + , signatures , typeDefinition ) import qualified Axel.Parse as Parse @@ -79,6 +81,7 @@ LChar char -> Parse.LiteralChar char LInt int -> Parse.LiteralInt int LString string -> Parse.LiteralString string +denormalizeExpression (ERawExpression rawSource) = Parse.LiteralString rawSource denormalizeImportSpecification :: ImportSpecification -> Parse.Expression denormalizeImportSpecification ImportAll = Parse.Symbol "all" @@ -108,9 +111,6 @@ , Parse.SExpression (map denormalizeExpression (fnDef ^. arguments)) , denormalizeExpression (fnDef ^. body) ] -denormalizeStatement (SPragma pragma) = - Parse.SExpression - [Parse.Symbol "pragma", Parse.LiteralString (pragma ^. pragmaSpecification)] denormalizeStatement (SMacroDefinition macroDef) = Parse.SExpression [ Parse.Symbol "macro" @@ -121,6 +121,9 @@ ] denormalizeStatement (SModuleDeclaration identifier) = Parse.SExpression [Parse.Symbol "module", Parse.Symbol identifier] +denormalizeStatement (SPragma pragma) = + Parse.SExpression + [Parse.Symbol "pragma", Parse.LiteralString (pragma ^. pragmaSpecification)] denormalizeStatement (SQualifiedImport qualifiedImport) = Parse.SExpression [ Parse.Symbol "importq" @@ -128,6 +131,8 @@ , Parse.Symbol $ qualifiedImport ^. alias , denormalizeImportSpecification (qualifiedImport ^. imports) ] +denormalizeStatement (SRawStatement rawSource) = + Parse.SExpression [Parse.Symbol "raw", Parse.LiteralString rawSource] denormalizeStatement (SRestrictedImport restrictedImport) = Parse.SExpression [ Parse.Symbol "import" @@ -136,6 +141,16 @@ ] denormalizeStatement (STopLevel (TopLevel statements)) = Parse.SExpression $ Parse.Symbol "begin" : map denormalizeStatement statements +denormalizeStatement (STypeclassDefinition typeclassDefinition) = + Parse.SExpression + (Parse.Symbol "class" : + Parse.SExpression + (Parse.Symbol "list" : + map denormalizeExpression (typeclassDefinition ^. constraints)) : + denormalizeExpression (typeclassDefinition ^. name) : + map + (denormalizeStatement . STypeSignature) + (typeclassDefinition ^. signatures)) denormalizeStatement (STypeclassInstance typeclassInstance) = Parse.SExpression (Parse.Symbol "instance" : diff --git a/src/Axel/Eff/Console.hs b/src/Axel/Eff/Console.hs new file mode 100644 --- /dev/null +++ b/src/Axel/Eff/Console.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Axel.Eff.Console where + +import Prelude hiding (putStr) +import qualified Prelude + +import Control.Monad.Freer + ( type (~>) + , Eff + , LastMember + , Member + , interpretM + , send + ) + +data Console r where + PutStr :: String -> Console () + +putStr :: (Member Console effs) => String -> Eff effs () +putStr = send . PutStr + +runEff :: (LastMember IO effs) => Eff (Console ': effs) ~> Eff effs +runEff = + interpretM + (\case + PutStr str -> Prelude.putStr str) + +putStrLn :: (Member Console effs) => String -> Eff effs () +putStrLn str = putStr (str <> "\n") diff --git a/src/Axel/Eff/FileSystem.hs b/src/Axel/Eff/FileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Axel/Eff/FileSystem.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeOperators #-} + +module Axel.Eff.FileSystem where + +import Prelude hiding (readFile, writeFile) +import qualified Prelude (readFile, writeFile) + +import Control.Monad (forM) +import Control.Monad.Freer + ( type (~>) + , Eff + , LastMember + , Member + , interpretM + , send + ) + +import qualified System.Directory + ( copyFile + , createDirectoryIfMissing + , doesDirectoryExist + , getCurrentDirectory + , getDirectoryContents + , getTemporaryDirectory + , removeFile + , setCurrentDirectory + ) +import System.FilePath (()) +import qualified System.IO.Strict as S (readFile) + +data FileSystem a where + CopyFile :: FilePath -> FilePath -> FileSystem () + CreateDirectoryIfMissing :: Bool -> FilePath -> FileSystem () + DoesDirectoryExist :: FilePath -> FileSystem Bool + GetCurrentDirectory :: FileSystem FilePath + GetDirectoryContents :: FilePath -> FileSystem [FilePath] + GetTemporaryDirectory :: FileSystem FilePath + ReadFile :: FilePath -> FileSystem String + RemoveFile :: FilePath -> FileSystem () + SetCurrentDirectory :: FilePath -> FileSystem () + WriteFile :: String -> FilePath -> FileSystem () + +copyFile :: (Member FileSystem effs) => FilePath -> FilePath -> Eff effs () +copyFile src dest = send $ CopyFile src dest + +createDirectoryIfMissing :: + (Member FileSystem effs) => Bool -> FilePath -> Eff effs () +createDirectoryIfMissing createParentDirs path = + send $ CreateDirectoryIfMissing createParentDirs path + +doesDirectoryExist :: (Member FileSystem effs) => FilePath -> Eff effs Bool +doesDirectoryExist = send . DoesDirectoryExist + +getCurrentDirectory :: (Member FileSystem effs) => Eff effs FilePath +getCurrentDirectory = send GetCurrentDirectory + +getDirectoryContents :: + (Member FileSystem effs) => FilePath -> Eff effs [FilePath] +getDirectoryContents = send . GetDirectoryContents + +getTemporaryDirectory :: (Member FileSystem effs) => Eff effs FilePath +getTemporaryDirectory = send GetTemporaryDirectory + +readFile :: (Member FileSystem effs) => FilePath -> Eff effs String +readFile = send . ReadFile + +removeFile :: (Member FileSystem effs) => FilePath -> Eff effs () +removeFile = send . RemoveFile + +setCurrentDirectory :: (Member FileSystem effs) => FilePath -> Eff effs () +setCurrentDirectory = send . SetCurrentDirectory + +writeFile :: (Member FileSystem effs) => String -> FilePath -> Eff effs () +writeFile contents path = send $ WriteFile contents path + +runEff :: (LastMember IO effs) => Eff (FileSystem ': effs) ~> Eff effs +runEff = + interpretM + (\case + CopyFile src dest -> System.Directory.copyFile src dest + CreateDirectoryIfMissing createParentDirs path -> + System.Directory.createDirectoryIfMissing createParentDirs path + DoesDirectoryExist path -> System.Directory.doesDirectoryExist path + GetCurrentDirectory -> System.Directory.getCurrentDirectory + GetDirectoryContents path -> System.Directory.getDirectoryContents path + GetTemporaryDirectory -> System.Directory.getTemporaryDirectory + ReadFile path -> S.readFile path + RemoveFile path -> System.Directory.removeFile path + SetCurrentDirectory path -> System.Directory.setCurrentDirectory path + WriteFile path contents -> Prelude.writeFile path contents) + +-- Adapted from http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html. +getDirectoryContentsRec :: + (Member FileSystem effs) => FilePath -> Eff effs [FilePath] +getDirectoryContentsRec dir = do + names <- getDirectoryContents dir + let properNames = filter (`notElem` [".", ".."]) names + paths <- + forM properNames $ \name -> do + let path = dir name + isDirectory <- doesDirectoryExist path + if isDirectory + then getDirectoryContentsRec path + else pure [path] + pure $ concat paths + +withCurrentDirectory :: + (Member FileSystem effs) => FilePath -> Eff effs a -> Eff effs a +withCurrentDirectory directory f = do + originalDirectory <- getCurrentDirectory + setCurrentDirectory directory + result <- f + setCurrentDirectory originalDirectory + pure result + +withTemporaryDirectory :: + (Member FileSystem effs) => (FilePath -> Eff effs a) -> Eff effs a +withTemporaryDirectory action = getTemporaryDirectory >>= action diff --git a/src/Axel/Eff/Process.hs b/src/Axel/Eff/Process.hs new file mode 100644 --- /dev/null +++ b/src/Axel/Eff/Process.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Axel.Eff.Process where + +import Control.Monad.Freer + ( type (~>) + , Eff + , LastMember + , Member + , interpretM + , send + ) + +import Data.Singletons (Sing, SingI, sing) +import Data.Singletons.TH (singletons) + +import qualified System.Environment (getArgs) +import System.Exit (ExitCode) +import qualified System.Process (readProcessWithExitCode) +import qualified System.Process.Typed (proc, runProcess) + +$(singletons + [d| + + data StreamSpecification = CreateStreams + | InheritStreams + |]) + +type family StreamsHandler (a :: StreamSpecification) (f :: * -> *) :: * + +type instance StreamsHandler 'CreateStreams f = + String -> f (ExitCode, String, String) + +type instance StreamsHandler 'InheritStreams f = f ExitCode + +type ProcessRunner' (streamSpec :: StreamSpecification) f + = forall streamsHandler. (streamsHandler ~ StreamsHandler streamSpec f) => + streamsHandler + +type ProcessRunnerPrimitive (streamSpec :: StreamSpecification) (f :: * -> *) + = FilePath -> [String] -> ProcessRunner' streamSpec f + +type ProcessRunner (streamSpec :: StreamSpecification) (f :: * -> *) + = (SingI streamSpec) => + ProcessRunner' streamSpec f + +data Process r where + GetArgs :: Process [String] + RunProcessCreatingStreams + :: FilePath -> [String] -> String -> Process (ExitCode, String, String) + RunProcessInheritingStreams :: FilePath -> [String] -> Process ExitCode + +getArgs :: (Member Process effs) => Eff effs [String] +getArgs = send GetArgs + +runProcessCreatingStreams :: + (Member Process effs) => ProcessRunnerPrimitive 'CreateStreams (Eff effs) +runProcessCreatingStreams cmd args stdin = + send $ RunProcessCreatingStreams cmd args stdin + +runProcessInheritingStreams :: + (Member Process effs) => ProcessRunnerPrimitive 'InheritStreams (Eff effs) +runProcessInheritingStreams cmd args = + send $ RunProcessInheritingStreams cmd args + +runEff :: (LastMember IO effs) => Eff (Process ': effs) ~> Eff effs +runEff = + interpretM + (\case + GetArgs -> System.Environment.getArgs + RunProcessCreatingStreams cmd args stdin -> + System.Process.readProcessWithExitCode cmd args stdin + RunProcessInheritingStreams cmd args -> + System.Process.Typed.runProcess (System.Process.Typed.proc cmd args)) + +runProcess :: + forall (streamSpec :: StreamSpecification) effs. (Member Process effs) + => FilePath + -> [String] + -> ProcessRunner streamSpec (Eff effs) +runProcess cmd args = + case sing :: Sing streamSpec of + SCreateStreams -> runProcessCreatingStreams cmd args + SInheritStreams -> runProcessInheritingStreams cmd args diff --git a/src/Axel/Eff/Resource.hs b/src/Axel/Eff/Resource.hs new file mode 100644 --- /dev/null +++ b/src/Axel/Eff/Resource.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeOperators #-} + +module Axel.Eff.Resource where + +import Axel.Eff.FileSystem as FS (FileSystem, readFile) + +import Control.Monad ((>=>)) +import Control.Monad.Freer + ( type (~>) + , Eff + , LastMember + , Member + , Members + , interpretM + , send + ) + +import Paths_axel (getDataFileName) + +import System.FilePath (()) + +newtype ResourceId = + ResourceId String + +data Resource a where + GetResourcePath :: ResourceId -> Resource FilePath + +getResourcePath :: (Member Resource effs) => ResourceId -> Eff effs FilePath +getResourcePath = send . GetResourcePath + +runEff :: (LastMember IO effs) => Eff (Resource ': effs) ~> Eff effs +runEff = + interpretM + (\case + GetResourcePath (ResourceId resource) -> + getDataFileName ("resources" resource)) + +readResource :: + (Members '[ FileSystem, Resource] effs) => ResourceId -> Eff effs String +readResource = getResourcePath >=> FS.readFile + +astDefinition :: ResourceId +astDefinition = ResourceId "autogenerated/macros/AST.hs" + +macroDefinitionAndEnvironmentFooter :: ResourceId +macroDefinitionAndEnvironmentFooter = + ResourceId "macros/MacroDefinitionAndEnvironmentFooter.hs" + +macroDefinitionAndEnvironmentHeader :: ResourceId +macroDefinitionAndEnvironmentHeader = + ResourceId "macros/MacroDefinitionAndEnvironmentHeader.hs" + +macroScaffold :: ResourceId +macroScaffold = ResourceId "macros/Scaffold.hs" + +newProjectTemplate :: ResourceId +newProjectTemplate = ResourceId "new-project-template" diff --git a/src/Axel/Error.hs b/src/Axel/Error.hs --- a/src/Axel/Error.hs +++ b/src/Axel/Error.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Axel.Error where import Axel.Parse.AST (Expression, toAxel) -import Control.Monad.Except (ExceptT, MonadError(throwError), runExceptT) +import Control.Monad ((>=>)) +import Control.Monad.Freer (type (~>), Eff, LastMember, send) +import Control.Monad.Freer.Error (runError) +import qualified Control.Monad.Freer.Error as Effs (Error) import Data.Semigroup ((<>)) @@ -31,15 +36,8 @@ fatal :: String -> String -> a fatal context message = error $ "[FATAL] " <> context <> " - " <> message -toIO :: (MonadError IOError m) => ExceptT Error m a -> m a -toIO f = do - result :: Either Error a <- runExceptT f - case result of - Left err -> throwError $ userError $ show err +runEff :: (Show e, LastMember IO effs) => Eff (Effs.Error e ': effs) ~> Eff effs +runEff = + runError >=> \case + Left err -> send $ ioError $ userError $ show err Right x -> pure x - -mapError :: (MonadError e' m) => ExceptT e m a -> (e -> e') -> m a -x `mapError` f = - runExceptT x >>= \case - Left err -> throwError (f err) - Right res -> pure res diff --git a/src/Axel/Haskell/File.hs b/src/Axel/Haskell/File.hs --- a/src/Axel/Haskell/File.hs +++ b/src/Axel/Haskell/File.hs @@ -1,32 +1,40 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Axel.Haskell.File where import Prelude hiding (putStr, putStrLn) import Axel.AST (ToHaskell(toHaskell)) -import Axel.Error (Error(EvalError), mapError) -import Axel.Haskell.GHC (ghcInterpret) -import Axel.Haskell.Prettify (prettifyHaskell) -import Axel.Macros (exhaustivelyExpandMacros, stripMacroDefinitions) -import Axel.Monad.Console (MonadConsole(putStr), putStrLn) -import Axel.Monad.FileSystem (MonadFileSystem) -import qualified Axel.Monad.FileSystem as FS - ( MonadFileSystem(readFile, writeFile) +import Axel.Eff.Console (putStrLn) +import qualified Axel.Eff.Console as Effs (Console) +import qualified Axel.Eff.FileSystem as Effs (FileSystem) +import qualified Axel.Eff.FileSystem as FS + ( readFile , withTemporaryDirectory + , writeFile ) -import Axel.Monad.Process (MonadProcess) -import Axel.Monad.Resource (MonadResource, readResource) -import qualified Axel.Monad.Resource as Res (astDefinition) +import Axel.Eff.Process (StreamSpecification(InheritStreams)) +import qualified Axel.Eff.Process as Effs (Process) +import Axel.Eff.Resource (readResource) +import qualified Axel.Eff.Resource as Effs (Resource) +import qualified Axel.Eff.Resource as Res (astDefinition) +import Axel.Error (Error) +import Axel.Haskell.Prettify (prettifyHaskell) +import Axel.Haskell.Stack (interpretFile) +import Axel.Macros (exhaustivelyExpandMacros) import Axel.Normalize (normalizeStatement) import Axel.Parse (Expression(Symbol), parseSource) import Axel.Utils.Recursion (Recursive(bottomUpFmap)) import Control.Lens.Operators ((.~)) -import Control.Monad.Except (MonadError) +import Control.Monad (void) +import Control.Monad.Freer (Eff, Members) +import qualified Control.Monad.Freer.Error as Effs (Error) import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) @@ -49,11 +57,11 @@ x -> x transpileSource :: - (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) + (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) => String - -> m String + -> Eff effs String transpileSource source = - prettifyHaskell . toHaskell . stripMacroDefinitions <$> + prettifyHaskell . toHaskell <$> (parseSource source >>= exhaustivelyExpandMacros . convertList . convertUnit >>= normalizeStatement) @@ -66,34 +74,30 @@ in basePath <> ".hs" transpileFile :: - (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) + (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) => FilePath -> FilePath - -> m () + -> Eff effs () transpileFile path newPath = do fileContents <- FS.readFile path newContents <- transpileSource fileContents + putStrLn "Writing file..." FS.writeFile newPath newContents -- | Transpile a file in place. transpileFile' :: - (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) + (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) => FilePath - -> m FilePath + -> Eff effs FilePath transpileFile' path = do let newPath = axelPathToHaskellPath path transpileFile path newPath pure newPath evalFile :: - ( MonadConsole m - , MonadError Error m - , MonadFileSystem m - , MonadProcess m - , MonadResource m - ) + (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) => FilePath - -> m () + -> Eff effs () evalFile path = do putStrLn ("Building " <> takeFileName path <> "...") FS.withTemporaryDirectory $ \tempDirectoryPath -> do @@ -102,5 +106,4 @@ let newPath = directory .~ tempDirectoryPath $ axelPathToHaskellPath path transpileFile path newPath putStrLn ("Running " <> takeFileName path <> "...") - output <- ghcInterpret newPath `mapError` EvalError - putStr output + void $ interpretFile @'InheritStreams newPath diff --git a/src/Axel/Haskell/GHC.hs b/src/Axel/Haskell/GHC.hs deleted file mode 100644 --- a/src/Axel/Haskell/GHC.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE UndecidableInstances #-} - -module Axel.Haskell.GHC where - -import Axel.Haskell.Stack (axelStackageId, stackageResolverWithAxel) -import Axel.Monad.Process (MonadProcess(runProcess)) - -import Control.Monad.Except (MonadError, throwError) - -import System.Exit (ExitCode(ExitFailure, ExitSuccess)) - -ghcCompile :: (MonadError String m, MonadProcess m) => FilePath -> m String -ghcCompile filePath = do - (exitCode, stdout, stderr) <- - runProcess - "stack" - [ "--resolver" - , stackageResolverWithAxel - , "ghc" - , "--" - , "-v0" - , "-ddump-json" - , filePath - ] - "" - case exitCode of - ExitSuccess -> pure stdout - ExitFailure _ -> throwError stderr - -ghcInterpret :: (MonadError String m, MonadProcess m) => FilePath -> m String -ghcInterpret filePath = do - (exitCode, stdout, stderr) <- - runProcess - "stack" - [ "--resolver" - , stackageResolverWithAxel - , "runghc" - , "--package" - , axelStackageId - , "--" - , filePath - ] - "" - case exitCode of - ExitSuccess -> pure stdout - ExitFailure _ -> throwError stderr diff --git a/src/Axel/Haskell/Project.hs b/src/Axel/Haskell/Project.hs --- a/src/Axel/Haskell/Project.hs +++ b/src/Axel/Haskell/Project.hs @@ -1,12 +1,20 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} module Axel.Haskell.Project where +import qualified Axel.Eff.Console as Effs (Console) +import Axel.Eff.FileSystem + ( copyFile + , getCurrentDirectory + , getDirectoryContentsRec + , removeFile + ) +import qualified Axel.Eff.FileSystem as Effs (FileSystem) +import qualified Axel.Eff.Process as Effs (Process) +import Axel.Eff.Resource (getResourcePath, newProjectTemplate) +import qualified Axel.Eff.Resource as Effs (Resource) import Axel.Error (Error) import Axel.Haskell.File (transpileFile') import Axel.Haskell.Stack @@ -16,15 +24,9 @@ , createStackProject , runStackProject ) -import Axel.Monad.Console (MonadConsole) -import Axel.Monad.FileSystem - ( MonadFileSystem(copyFile, getCurrentDirectory, removeFile) - , getDirectoryContentsRec - ) -import Axel.Monad.Process (MonadProcess) -import Axel.Monad.Resource (MonadResource(getResourcePath), newProjectTemplate) -import Control.Monad.Except (MonadError) +import Control.Monad.Freer (Eff, Members) +import qualified Control.Monad.Freer.Error as Effs (Error) import Data.Semigroup ((<>)) import qualified Data.Text as T (isSuffixOf, pack) @@ -34,7 +36,9 @@ type ProjectPath = FilePath newProject :: - (MonadFileSystem m, MonadProcess m, MonadResource m) => String -> m () + Members '[ Effs.FileSystem, Effs.Process, Effs.Resource] effs + => String + -> Eff effs () newProject projectName = do createStackProject projectName addStackDependency axelStackageSpecifier projectName @@ -47,8 +51,8 @@ mapM_ copyAxel ["Setup", "app" "Main", "src" "Lib", "test" "Spec"] transpileProject :: - (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) - => m [FilePath] + (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) + => Eff effs [FilePath] transpileProject = do files <- getDirectoryContentsRec "." let axelFiles = @@ -56,13 +60,8 @@ mapM transpileFile' axelFiles buildProject :: - ( MonadConsole m - , MonadError Error m - , MonadFileSystem m - , MonadProcess m - , MonadResource m - ) - => m () + (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) + => Eff effs () buildProject = do projectPath <- getCurrentDirectory hsPaths <- transpileProject @@ -70,6 +69,6 @@ mapM_ removeFile hsPaths runProject :: - (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m) - => m () + (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process] effs) + => Eff effs () runProject = getCurrentDirectory >>= runStackProject diff --git a/src/Axel/Haskell/Stack.hs b/src/Axel/Haskell/Stack.hs --- a/src/Axel/Haskell/Stack.hs +++ b/src/Axel/Haskell/Stack.hs @@ -1,29 +1,41 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} module Axel.Haskell.Stack where import Prelude hiding (putStrLn) -import Axel.Error (Error(ProjectError), fatal) -import Axel.Monad.Console (MonadConsole, putStrLn) -import Axel.Monad.FileSystem (MonadFileSystem) -import qualified Axel.Monad.FileSystem as FS - ( MonadFileSystem(readFile, writeFile) +import Axel.Eff.Console (putStrLn) +import qualified Axel.Eff.Console as Effs (Console) +import qualified Axel.Eff.FileSystem as FS + ( readFile , withCurrentDirectory + , writeFile ) -import Axel.Monad.Process - ( MonadProcess(runProcess, runProcessInheritingStreams) +import qualified Axel.Eff.FileSystem as Effs (FileSystem) +import Axel.Eff.Process + ( ProcessRunner + , StreamSpecification(CreateStreams, InheritStreams) + , runProcess ) +import qualified Axel.Eff.Process as Effs (Process) +import Axel.Error (Error(ProjectError), fatal) import Control.Lens.Operators ((%~)) import Control.Monad (void) -import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Freer (Eff, Member, Members) +import Control.Monad.Freer.Error (throwError) +import qualified Control.Monad.Freer.Error as Effs (Error) import Data.Aeson.Lens (_Array, key) import qualified Data.ByteString.Char8 as B (pack, unpack) @@ -52,7 +64,7 @@ type Version = String stackageResolverWithAxel :: StackageResolver -stackageResolverWithAxel = "nightly-2018-08-20" +stackageResolverWithAxel = "nightly" axelStackageVersion :: Version axelStackageVersion = showVersion version @@ -64,13 +76,16 @@ axelStackageSpecifier = "axel ==" <> axelStackageVersion getStackProjectTargets :: - (Monad m, MonadFileSystem m, MonadProcess m) => ProjectPath -> m [Target] + (Members '[ Effs.FileSystem, Effs.Process] effs) + => ProjectPath + -> Eff effs [Target] getStackProjectTargets projectPath = FS.withCurrentDirectory projectPath $ do - (_, _, stderr) <- runProcess "stack" ["ide", "targets"] "" + (_, _, stderr) <- runProcess @'CreateStreams "stack" ["ide", "targets"] "" pure $ lines stderr -addStackDependency :: (MonadFileSystem m) => StackageId -> ProjectPath -> m () +addStackDependency :: + (Member Effs.FileSystem effs) => StackageId -> ProjectPath -> Eff effs () addStackDependency dependencyId projectPath = FS.withCurrentDirectory projectPath $ do let packageConfigPath = "package.yaml" @@ -85,13 +100,14 @@ Left _ -> fatal "addStackDependency" "0001" buildStackProject :: - (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m) + (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process] effs) => ProjectPath - -> m () + -> Eff effs () buildStackProject projectPath = do putStrLn ("Building " <> takeFileName projectPath <> "...") result <- - FS.withCurrentDirectory projectPath $ runProcess "stack" ["build"] "" + FS.withCurrentDirectory projectPath $ + runProcess @'CreateStreams "stack" ["build"] "" case result of (ExitSuccess, _, _) -> pure () (ExitFailure _, stdout, stderr) -> @@ -100,21 +116,25 @@ ("Project failed to build.\n\nStdout:\n" <> stdout <> "\n\nStderr:\n" <> stderr) -createStackProject :: (MonadFileSystem m, MonadProcess m) => String -> m () +createStackProject :: + (Member Effs.FileSystem effs, Member Effs.Process effs) + => String + -> Eff effs () createStackProject projectName = do - void $ runProcess "stack" ["new", projectName, "new-template"] "" + void $ + runProcess @'CreateStreams "stack" ["new", projectName, "new-template"] "" setStackageResolver projectName stackageResolverWithAxel runStackProject :: - (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m) + (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process] effs) => ProjectPath - -> m () + -> Eff effs () runStackProject projectPath = do targets <- getStackProjectTargets projectPath case findExeTargets targets of [target] -> do putStrLn ("Running " <> target <> "...") - void $ runProcessInheritingStreams "stack" ["exec", target] + void $ runProcess @'InheritStreams "stack" ["exec", target] _ -> throwError $ ProjectError "No executable target was unambiguously found!" where @@ -128,10 +148,30 @@ [] setStackageResolver :: - (MonadFileSystem m, MonadProcess m) + (Member Effs.FileSystem effs, Member Effs.Process effs) => ProjectPath -> StackageResolver - -> m () + -> Eff effs () setStackageResolver projectPath resolver = void $ FS.withCurrentDirectory projectPath $ - runProcess "stack" ["config", "set", "resolver", resolver] "" + runProcess @'CreateStreams "stack" ["config", "set", "resolver", resolver] "" + +includeAxelArguments :: [String] +includeAxelArguments = + ["--resolver", stackageResolverWithAxel, "--package", axelStackageId] + +compileFile :: + forall (streamSpec :: StreamSpecification) effs. (Member Effs.Process effs) + => FilePath + -> ProcessRunner streamSpec (Eff effs) +compileFile filePath = + let args = [["ghc"], includeAxelArguments, ["--", filePath]] + in runProcess @streamSpec @effs "stack" (concat args) + +interpretFile :: + forall (streamSpec :: StreamSpecification) effs. (Member Effs.Process effs) + => FilePath + -> ProcessRunner streamSpec (Eff effs) +interpretFile filePath = + let args = [["runghc"], includeAxelArguments, ["--", filePath]] + in runProcess @streamSpec @effs "stack" (concat args) diff --git a/src/Axel/Macros.hs b/src/Axel/Macros.hs --- a/src/Axel/Macros.hs +++ b/src/Axel/Macros.hs @@ -1,38 +1,43 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Axel.Macros where import Axel.AST - ( Identifier - , MacroDefinition + ( MacroDefinition , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition, - SModuleDeclaration, SPragma, SQualifiedImport, SRestrictedImport, - STopLevel, STypeSignature, STypeSynonym, STypeclassInstance, - SUnrestrictedImport) + SModuleDeclaration, SPragma, SQualifiedImport, SRawStatement, + SRestrictedImport, STopLevel, STypeSignature, STypeSynonym, + STypeclassInstance, SUnrestrictedImport) , ToHaskell(toHaskell) , functionDefinition , name - , statements ) import Axel.Denormalize (denormalizeStatement) -import Axel.Error (Error(MacroError)) -import Axel.Haskell.GHC (ghcInterpret) -import Axel.Haskell.Prettify (prettifyHaskell) -import Axel.Monad.FileSystem (MonadFileSystem) -import qualified Axel.Monad.FileSystem as FS - ( MonadFileSystem(createDirectoryIfMissing, writeFile) +import qualified Axel.Eff.FileSystem as Effs (FileSystem) +import qualified Axel.Eff.FileSystem as FS + ( createDirectoryIfMissing , withCurrentDirectory , withTemporaryDirectory + , writeFile ) -import Axel.Monad.Process (MonadProcess) -import Axel.Monad.Resource (MonadResource, readResource) -import qualified Axel.Monad.Resource as Res +import Axel.Eff.Process (StreamSpecification(CreateStreams)) +import qualified Axel.Eff.Process as Effs (Process) +import Axel.Eff.Resource (readResource) +import qualified Axel.Eff.Resource as Effs (Resource) +import qualified Axel.Eff.Resource as Res ( astDefinition , macroDefinitionAndEnvironmentFooter , macroDefinitionAndEnvironmentHeader , macroScaffold ) +import Axel.Error (Error(MacroError)) +import Axel.Haskell.Prettify (prettifyHaskell) +import Axel.Haskell.Stack (interpretFile) import Axel.Normalize (normalizeStatement) import qualified Axel.Parse as Parse ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression, @@ -43,31 +48,46 @@ ) import Axel.Utils.Display (Delimiter(Newlines), delimit, isOperator) import Axel.Utils.Function (uncurry3) -import Axel.Utils.Recursion - ( Recursive(bottomUpFmap, bottomUpTraverse) - , exhaustM - ) +import Axel.Utils.Recursion (Recursive(bottomUpTraverse), exhaustM) import Axel.Utils.String (replace) import Control.Lens.Cons (snoc) import Control.Lens.Operators ((%~), (^.)) import Control.Lens.Tuple (_1, _2) import Control.Monad (foldM) -import Control.Monad.Except (MonadError, catchError, runExceptT, throwError) +import Control.Monad.Freer (Eff, Members) +import Control.Monad.Freer.Error (throwError) +import qualified Control.Monad.Freer.Error as Effs (Error) import Data.Function ((&)) import Data.List.NonEmpty (NonEmpty, nonEmpty) -import qualified Data.List.NonEmpty as NE (head, toList) +import qualified Data.List.NonEmpty as NE (head, map, toList) import Data.Semigroup ((<>)) +import qualified Data.Text as T (isSuffixOf, pack) +import System.Exit (ExitCode(ExitFailure)) import System.FilePath (()) +hygenisizeMacroName :: String -> String +hygenisizeMacroName oldName = + let suffix = + if isOperator oldName + then "%%%%%%%%%%" + else "_AXEL_AUTOGENERATED_MACRO_DEFINITION" + in if T.pack suffix `T.isSuffixOf` T.pack oldName + then oldName + else oldName <> suffix + +hygenisizeMacroDefinition :: MacroDefinition -> MacroDefinition +hygenisizeMacroDefinition macroDef = + macroDef & functionDefinition . name %~ hygenisizeMacroName + generateMacroProgram :: - (MonadError Error m, MonadFileSystem m, MonadResource m) + (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Resource] effs) => NonEmpty MacroDefinition -> [Statement] -> [Parse.Expression] - -> m (String, String, String) + -> Eff effs (String, String, String) generateMacroProgram macroDefs env applicationArgs = do astDef <- readResource Res.astDefinition scaffold <- getScaffold @@ -78,25 +98,19 @@ let defNamePlaceholder = "%%%MACRO_NAME%%%" in replace defNamePlaceholder newMacroName oldMacroName = NE.head macroDefs ^. functionDefinition . name - newMacroName = - oldMacroName <> - if isOperator oldMacroName - then "%%%%%%%%%%" - else "_AXEL_AUTOGENERATED_MACRO_DEFINITION" + newMacroName = hygenisizeMacroName oldMacroName getMacroDefAndEnvHeader = insertDefName <$> readResource Res.macroDefinitionAndEnvironmentHeader getMacroDefAndEnvFooter = do - hygenicMacroDefs <- - traverse - (replaceName oldMacroName newMacroName . SMacroDefinition) - macroDefs + let hygenicMacroDefs = NE.map hygenisizeMacroDefinition macroDefs let source = prettifyHaskell $ delimit Newlines $ - map toHaskell (env <> NE.toList hygenicMacroDefs) + map + toHaskell + (env <> NE.toList (NE.map SMacroDefinition hygenicMacroDefs)) footer <- insertDefName <$> readResource Res.macroDefinitionAndEnvironmentFooter - pure (unlines [source, footer]) - getScaffold :: (Monad m, MonadFileSystem m, MonadResource m) => m String + pure $ unlines [source, footer] getScaffold = let insertApplicationArgs = let applicationArgsPlaceholder = "%%%ARGUMENTS%%%" @@ -105,9 +119,9 @@ readResource Res.macroScaffold expansionPass :: - (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) + (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) => Parse.Expression - -> m Parse.Expression + -> Eff effs Parse.Expression expansionPass programExpr = Parse.topLevelExpressionsToProgram . map denormalizeStatement <$> expandMacros (Parse.programToTopLevelExpressions programExpr) @@ -123,9 +137,9 @@ Parse.SExpression (Parse.Symbol "begin" : stmts) exhaustivelyExpandMacros :: - (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) + (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) => Parse.Expression - -> m Parse.Expression + -> Eff effs Parse.Expression exhaustivelyExpandMacros = exhaustM expansionPass isStatementNonconflicting :: Statement -> Bool @@ -135,6 +149,7 @@ isStatementNonconflicting (SMacroDefinition _) = True isStatementNonconflicting (SModuleDeclaration _) = False isStatementNonconflicting (SQualifiedImport _) = True +isStatementNonconflicting (SRawStatement _) = True isStatementNonconflicting (SRestrictedImport _) = True isStatementNonconflicting (STopLevel _) = False isStatementNonconflicting (STypeclassInstance _) = True @@ -143,37 +158,27 @@ isStatementNonconflicting (SUnrestrictedImport _) = True expandMacros :: - (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) + (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) => [Parse.Expression] - -> m [Statement] -expandMacros topLevelExprs = - fst <$> - foldM - (\acc@(stmts, macroDefs) expr -> do - expandedExprs <- fullyExpandExpr stmts macroDefs expr - foldM - (\acc' expandedExpr -> do - stmt <- normalizeStatement expandedExpr - pure $ acc' & - case stmt of - SMacroDefinition macroDefinition -> - _2 %~ flip snoc macroDefinition - _ -> _1 %~ flip snoc stmt) - acc - expandedExprs) - ([], []) - topLevelExprs + -> Eff effs [Statement] +expandMacros topLevelExprs = do + (stmts, macroDefs) <- + foldM + (\acc@(stmts, macroDefs) expr -> do + expandedExprs <- fullyExpandExpr stmts macroDefs expr + foldM + (\acc' expandedExpr -> do + stmt <- normalizeStatement expandedExpr + pure $ acc' & + case stmt of + SMacroDefinition macroDef -> _2 %~ flip snoc macroDef + _ -> _1 %~ flip snoc stmt) + acc + expandedExprs) + ([], []) + topLevelExprs + pure $ stmts <> map (SMacroDefinition . hygenisizeMacroDefinition) macroDefs where - fullyExpandExpr :: - ( MonadError Error m - , MonadFileSystem m - , MonadProcess m - , MonadResource m - ) - => [Statement] - -> [MacroDefinition] - -> Parse.Expression - -> m [Parse.Expression] fullyExpandExpr stmts allMacroDefs expr = do let program = Parse.topLevelExpressionsToProgram [expr] expandedExpr <- @@ -185,20 +190,16 @@ foldM (\acc x -> case x of - Parse.LiteralChar _ -> pure $ acc ++ [x] - Parse.LiteralInt _ -> pure $ acc ++ [x] - Parse.LiteralString _ -> pure $ acc ++ [x] - Parse.SExpression [] -> pure $ acc ++ [x] Parse.SExpression (function:args) -> case lookupMacroDefinitions function allMacroDefs of Just macroDefs -> - (acc ++) <$> + (acc <>) <$> expandMacroApplication macroDefs (filter isStatementNonconflicting stmts) args - Nothing -> pure $ acc ++ [x] - Parse.Symbol _ -> pure $ acc ++ [x]) + Nothing -> pure $ snoc acc x + _ -> pure $ snoc acc x) [] xs x -> pure x)) @@ -206,11 +207,11 @@ pure $ Parse.programToTopLevelExpressions expandedExpr expandMacroApplication :: - (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) + (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs) => NonEmpty MacroDefinition -> [Statement] -> [Parse.Expression] - -> m [Parse.Expression] + -> Eff effs [Parse.Expression] expandMacroApplication macroDefs auxEnv args = do macroProgram <- generateMacroProgram macroDefs auxEnv args newSource <- uncurry3 evalMacro macroProgram @@ -231,45 +232,16 @@ Parse.Symbol identifier -> macroDef ^. functionDefinition . name == identifier -stripMacroDefinitions :: Statement -> Statement -stripMacroDefinitions = - \case - STopLevel topLevel -> - STopLevel $ - (statements %~ filter (not . isMacroDefinitionStatement)) topLevel - x -> x - isMacroDefinitionStatement :: Statement -> Bool isMacroDefinitionStatement (SMacroDefinition _) = True isMacroDefinitionStatement _ = False -replaceName :: - (MonadError Error m) - => Identifier - -> Identifier - -> Statement - -> m Statement -replaceName oldName newName = - normalize . bottomUpFmap replaceSymbol . denormalizeStatement - where - normalize expr = - normalizeStatement expr `catchError` \_ -> - throwError (MacroError $ "Invalid macro name: `" <> oldName <> "`!") - replaceSymbol expr = - case expr of - Parse.Symbol identifier -> - Parse.Symbol $ - if identifier == oldName - then newName - else identifier - _ -> expr - evalMacro :: - (MonadError Error m, MonadFileSystem m, MonadProcess m) + (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process] effs) => String -> String -> String - -> m String + -> Eff effs String evalMacro astDefinition scaffold macroDefinitionAndEnvironment = FS.withTemporaryDirectory $ \directoryName -> FS.withCurrentDirectory directoryName $ do @@ -283,10 +255,10 @@ macroDefinitionAndEnvironmentFileName macroDefinitionAndEnvironment FS.writeFile scaffoldFileName scaffold - runExceptT (ghcInterpret scaffoldFileName) >>= \case - Left err -> + interpretFile @'CreateStreams scaffoldFileName "" >>= \case + (ExitFailure _, _, stderr) -> throwError $ MacroError ("Temporary directory: " <> directoryName <> "\n\n" <> "Error:\n" <> - err) - Right res -> pure res + stderr) + (_, stdout, _) -> pure stdout diff --git a/src/Axel/Monad/Console.hs b/src/Axel/Monad/Console.hs deleted file mode 100644 --- a/src/Axel/Monad/Console.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE UndecidableInstances #-} - -module Axel.Monad.Console where - -import Prelude hiding (putStr) -import qualified Prelude - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Identity (IdentityT) -import Control.Monad.Trans (MonadTrans, lift) -import Control.Monad.Trans.Cont (ContT) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Maybe (MaybeT) -import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST) -import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT) -import qualified Control.Monad.Trans.State.Strict as StrictState (StateT) -import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT) -import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT) - -class (Monad m) => - MonadConsole m - where - putStr :: String -> m () - default putStr :: (MonadTrans t, MonadConsole m', m ~ t m') => - String -> m () - putStr = lift . putStr - -instance (MonadConsole m) => MonadConsole (ContT r m) - -instance (MonadConsole m) => MonadConsole (ExceptT e m) - -instance (MonadConsole m) => MonadConsole (IdentityT m) - -instance (MonadConsole m) => MonadConsole (MaybeT m) - -instance (MonadConsole m) => MonadConsole (ReaderT r m) - -instance (Monoid w, MonadConsole m) => MonadConsole (LazyRWS.RWST r w s m) - -instance (Monoid w, MonadConsole m) => - MonadConsole (StrictRWS.RWST r w s m) - -instance (MonadConsole m) => MonadConsole (LazyState.StateT s m) - -instance (MonadConsole m) => MonadConsole (StrictState.StateT s m) - -instance (Monoid w, MonadConsole m) => - MonadConsole (LazyWriter.WriterT w m) - -instance (Monoid w, MonadConsole m) => - MonadConsole (StrictWriter.WriterT w m) - -instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadConsole m where - putStr :: String -> m () - putStr = liftIO . Prelude.putStr - -putStrLn :: (MonadConsole m) => String -> m () -putStrLn str = putStr (str <> "\n") diff --git a/src/Axel/Monad/FileSystem.hs b/src/Axel/Monad/FileSystem.hs deleted file mode 100644 --- a/src/Axel/Monad/FileSystem.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE UndecidableInstances #-} - -module Axel.Monad.FileSystem where - -import Prelude hiding (readFile, writeFile) -import qualified Prelude (readFile, writeFile) - -import Control.Monad (forM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Identity (IdentityT) -import Control.Monad.Trans (MonadTrans, lift) -import Control.Monad.Trans.Cont (ContT) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Maybe (MaybeT) -import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST) -import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT) -import qualified Control.Monad.Trans.State.Strict as StrictState (StateT) -import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT) -import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT) - -import qualified System.Directory - ( copyFile - , createDirectoryIfMissing - , doesDirectoryExist - , getCurrentDirectory - , getDirectoryContents - , getTemporaryDirectory - , removeFile - , setCurrentDirectory - ) -import System.FilePath (()) -import qualified System.IO.Strict as S (readFile) - -class (Monad m) => - MonadFileSystem m - where - copyFile :: FilePath -> FilePath -> m () - default copyFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') => - FilePath -> FilePath -> m () - copyFile src dest = lift $ copyFile src dest - createDirectoryIfMissing :: Bool -> FilePath -> m () - default createDirectoryIfMissing :: ( MonadTrans t - , MonadFileSystem m' - , m ~ t m' - ) => - Bool -> FilePath -> m () - createDirectoryIfMissing createParents path = - lift $ createDirectoryIfMissing createParents path - doesDirectoryExist :: FilePath -> m Bool - default doesDirectoryExist :: (MonadTrans t, MonadFileSystem m', m ~ t m') => - FilePath -> m Bool - doesDirectoryExist = lift . doesDirectoryExist - getCurrentDirectory :: m FilePath - default getCurrentDirectory :: (MonadTrans t, MonadFileSystem m', m ~ t m') => - m FilePath - getCurrentDirectory = lift getCurrentDirectory - getDirectoryContents :: FilePath -> m [FilePath] - default getDirectoryContents :: (MonadTrans t, MonadFileSystem m', m ~ t m') => - FilePath -> m [FilePath] - getDirectoryContents = lift . getDirectoryContents - getTemporaryDirectory :: m FilePath - default getTemporaryDirectory :: (MonadTrans t, MonadFileSystem m', m ~ t m') => - m FilePath - getTemporaryDirectory = lift getTemporaryDirectory - readFile :: FilePath -> m String - default readFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') => - FilePath -> m String - readFile = lift . readFile - removeFile :: FilePath -> m () - default removeFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') => - FilePath -> m () - removeFile = lift . removeFile - setCurrentDirectory :: FilePath -> m () - default setCurrentDirectory :: (MonadTrans t, MonadFileSystem m', m ~ t m') => - FilePath -> m () - setCurrentDirectory = lift . setCurrentDirectory - writeFile :: FilePath -> String -> m () - default writeFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') => - String -> FilePath -> m () - writeFile path contents = lift $ writeFile path contents - -instance (MonadFileSystem m) => MonadFileSystem (ContT r m) - -instance (MonadFileSystem m) => MonadFileSystem (ExceptT e m) - -instance (MonadFileSystem m) => MonadFileSystem (IdentityT m) - -instance (MonadFileSystem m) => MonadFileSystem (MaybeT m) - -instance (MonadFileSystem m) => MonadFileSystem (ReaderT r m) - -instance (Monoid w, MonadFileSystem m) => - MonadFileSystem (LazyRWS.RWST r w s m) - -instance (Monoid w, MonadFileSystem m) => - MonadFileSystem (StrictRWS.RWST r w s m) - -instance (MonadFileSystem m) => MonadFileSystem (LazyState.StateT s m) - -instance (MonadFileSystem m) => MonadFileSystem (StrictState.StateT s m) - -instance (Monoid w, MonadFileSystem m) => - MonadFileSystem (LazyWriter.WriterT w m) - -instance (Monoid w, MonadFileSystem m) => - MonadFileSystem (StrictWriter.WriterT w m) - -instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadFileSystem m where - copyFile :: FilePath -> FilePath -> m () - copyFile src dest = liftIO $ System.Directory.copyFile src dest - createDirectoryIfMissing :: Bool -> FilePath -> m () - createDirectoryIfMissing createParentDirs path = - liftIO $ System.Directory.createDirectoryIfMissing createParentDirs path - doesDirectoryExist :: FilePath -> m Bool - doesDirectoryExist = liftIO . System.Directory.doesDirectoryExist - getCurrentDirectory :: m FilePath - getCurrentDirectory = liftIO System.Directory.getCurrentDirectory - getDirectoryContents :: FilePath -> m [FilePath] - getDirectoryContents = liftIO . System.Directory.getDirectoryContents - getTemporaryDirectory :: m FilePath - getTemporaryDirectory = liftIO System.Directory.getTemporaryDirectory - readFile :: FilePath -> m String - readFile = liftIO . S.readFile - removeFile :: FilePath -> m () - removeFile = liftIO . System.Directory.removeFile - setCurrentDirectory :: FilePath -> m () - setCurrentDirectory = liftIO . System.Directory.setCurrentDirectory - writeFile :: FilePath -> String -> m () - writeFile filePath contents = liftIO $ Prelude.writeFile filePath contents - --- Adapted from http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html. -getDirectoryContentsRec :: - (Monad m, MonadFileSystem m) => FilePath -> m [FilePath] -getDirectoryContentsRec dir = do - names <- getDirectoryContents dir - let properNames = filter (`notElem` [".", ".."]) names - paths <- - forM properNames $ \name -> do - let path = dir name - isDirectory <- doesDirectoryExist path - if isDirectory - then getDirectoryContentsRec path - else pure [path] - pure $ concat paths - -withCurrentDirectory :: (MonadFileSystem m) => FilePath -> m a -> m a -withCurrentDirectory directory f = do - originalDirectory <- getCurrentDirectory - setCurrentDirectory directory - result <- f - setCurrentDirectory originalDirectory - pure result - -withTemporaryDirectory :: (MonadFileSystem m) => (FilePath -> m a) -> m a -withTemporaryDirectory action = getTemporaryDirectory >>= action diff --git a/src/Axel/Monad/Process.hs b/src/Axel/Monad/Process.hs deleted file mode 100644 --- a/src/Axel/Monad/Process.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE UndecidableInstances #-} - -module Axel.Monad.Process where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Identity (IdentityT) -import Control.Monad.Trans (MonadTrans, lift) -import Control.Monad.Trans.Cont (ContT) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Maybe (MaybeT) -import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST) -import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT) -import qualified Control.Monad.Trans.State.Strict as StrictState (StateT) -import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT) -import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT) - -import qualified System.Environment (getArgs) -import System.Exit (ExitCode) -import qualified System.Process (readProcessWithExitCode) -import qualified System.Process.Typed (proc, runProcess) - -class (Monad m) => - MonadProcess m - where - getArgs :: m [String] - default getArgs :: (MonadTrans t, MonadProcess m', m ~ t m') => - m [String] - getArgs = lift getArgs - runProcess :: FilePath -> [String] -> String -> m (ExitCode, String, String) - default runProcess :: (MonadTrans t, MonadProcess m', m ~ t m') => - FilePath -> [String] -> String -> m (ExitCode, String, String) - runProcess cmd args stdin = lift $ runProcess cmd args stdin - runProcessInheritingStreams :: FilePath -> [String] -> m ExitCode - default runProcessInheritingStreams :: ( MonadTrans t - , MonadProcess m' - , m ~ t m' - ) => - FilePath -> [String] -> m ExitCode - runProcessInheritingStreams cmd args = - lift $ runProcessInheritingStreams cmd args - -instance (MonadProcess m) => MonadProcess (ContT r m) - -instance (MonadProcess m) => MonadProcess (ExceptT e m) - -instance (MonadProcess m) => MonadProcess (IdentityT m) - -instance (MonadProcess m) => MonadProcess (MaybeT m) - -instance (MonadProcess m) => MonadProcess (ReaderT r m) - -instance (Monoid w, MonadProcess m) => MonadProcess (LazyRWS.RWST r w s m) - -instance (Monoid w, MonadProcess m) => - MonadProcess (StrictRWS.RWST r w s m) - -instance (MonadProcess m) => MonadProcess (LazyState.StateT s m) - -instance (MonadProcess m) => MonadProcess (StrictState.StateT s m) - -instance (Monoid w, MonadProcess m) => - MonadProcess (LazyWriter.WriterT w m) - -instance (Monoid w, MonadProcess m) => - MonadProcess (StrictWriter.WriterT w m) - -instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadProcess m where - getArgs :: m [String] - getArgs = liftIO System.Environment.getArgs - runProcess :: FilePath -> [String] -> String -> m (ExitCode, String, String) - runProcess cmd args stdin = - liftIO $ System.Process.readProcessWithExitCode cmd args stdin - runProcessInheritingStreams cmd args = - liftIO $ - System.Process.Typed.runProcess (System.Process.Typed.proc cmd args) diff --git a/src/Axel/Monad/Resource.hs b/src/Axel/Monad/Resource.hs deleted file mode 100644 --- a/src/Axel/Monad/Resource.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE UndecidableInstances #-} - -module Axel.Monad.Resource where - -import Axel.Monad.FileSystem as FS (MonadFileSystem(readFile)) - -import Control.Monad ((>=>)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Identity (IdentityT) -import Control.Monad.Trans (MonadTrans, lift) -import Control.Monad.Trans.Cont (ContT) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Maybe (MaybeT) -import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST) -import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT) -import qualified Control.Monad.Trans.State.Strict as StrictState (StateT) -import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT) -import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT) - -import Paths_axel (getDataFileName) - -import System.FilePath (()) - -newtype ResourceId = - ResourceId String - -class (Monad m) => - MonadResource m - where - getResourcePath :: ResourceId -> m FilePath - default getResourcePath :: (MonadTrans t, MonadResource m', m ~ t m') => - ResourceId -> m FilePath - getResourcePath = lift . getResourcePath - -instance (MonadResource m) => MonadResource (ContT r m) - -instance (MonadResource m) => MonadResource (ExceptT e m) - -instance (MonadResource m) => MonadResource (IdentityT m) - -instance (MonadResource m) => MonadResource (MaybeT m) - -instance (MonadResource m) => MonadResource (ReaderT r m) - -instance (Monoid w, MonadResource m) => - MonadResource (LazyRWS.RWST r w s m) - -instance (Monoid w, MonadResource m) => - MonadResource (StrictRWS.RWST r w s m) - -instance (MonadResource m) => MonadResource (LazyState.StateT s m) - -instance (MonadResource m) => MonadResource (StrictState.StateT s m) - -instance (Monoid w, MonadResource m) => - MonadResource (LazyWriter.WriterT w m) - -instance (Monoid w, MonadResource m) => - MonadResource (StrictWriter.WriterT w m) - -instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadResource m where - getResourcePath :: ResourceId -> m FilePath - getResourcePath (ResourceId resource) = - liftIO $ getDataFileName ("resources" resource) - -readResource :: (MonadFileSystem m, MonadResource m) => ResourceId -> m String -readResource = getResourcePath >=> FS.readFile - -astDefinition :: ResourceId -astDefinition = ResourceId "autogenerated/macros/AST.hs" - -macroDefinitionAndEnvironmentFooter :: ResourceId -macroDefinitionAndEnvironmentFooter = - ResourceId "macros/MacroDefinitionAndEnvironmentFooter.hs" - -macroDefinitionAndEnvironmentHeader :: ResourceId -macroDefinitionAndEnvironmentHeader = - ResourceId "macros/MacroDefinitionAndEnvironmentHeader.hs" - -macroScaffold :: ResourceId -macroScaffold = ResourceId "macros/Scaffold.hs" - -newProjectTemplate :: ResourceId -newProjectTemplate = ResourceId "new-project-template" diff --git a/src/Axel/Normalize.hs b/src/Axel/Normalize.hs --- a/src/Axel/Normalize.hs +++ b/src/Axel/Normalize.hs @@ -8,7 +8,7 @@ ( CaseBlock(CaseBlock) , DataDeclaration(DataDeclaration) , Expression(ECaseBlock, EEmptySExpression, EFunctionApplication, - EIdentifier, ELambda, ELetBlock, ELiteral) + EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression) , FunctionApplication(FunctionApplication) , FunctionDefinition(FunctionDefinition) , Identifier @@ -22,13 +22,14 @@ , QualifiedImport(QualifiedImport) , RestrictedImport(RestrictedImport) , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition, - SModuleDeclaration, SPragma, SQualifiedImport, SRestrictedImport, - STopLevel, STypeSignature, STypeSynonym, STypeclassInstance, - SUnrestrictedImport) + SModuleDeclaration, SPragma, SQualifiedImport, SRawStatement, + SRestrictedImport, STopLevel, STypeSignature, STypeSynonym, + STypeclassDefinition, STypeclassInstance, SUnrestrictedImport) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor) , TypeSignature(TypeSignature) , TypeSynonym(TypeSynonym) + , TypeclassDefinition(TypeclassDefinition) , TypeclassInstance(TypeclassInstance) ) import Axel.Error (Error(NormalizeError)) @@ -37,9 +38,12 @@ Symbol) ) -import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Freer (Eff, Member) +import Control.Monad.Freer.Error (throwError) +import qualified Control.Monad.Freer.Error as Effs (Error) -normalizeExpression :: (MonadError Error m) => Parse.Expression -> m Expression +normalizeExpression :: + (Member (Effs.Error Error) effs) => Parse.Expression -> Eff effs Expression normalizeExpression (Parse.LiteralChar char) = pure $ ELiteral (LChar char) normalizeExpression (Parse.LiteralInt int) = pure $ ELiteral (LInt int) normalizeExpression (Parse.LiteralString string) = @@ -71,6 +75,16 @@ bindings in ELetBlock <$> (LetBlock <$> normalizedBindings <*> normalizeExpression body) + [Parse.Symbol "raw", rawSource] -> + let normalizedRawSource = + case rawSource of + Parse.LiteralString x -> pure x + x -> + throwError $ + NormalizeError + "`raw` takes strings representing the code to inject directly." + [x, expr] + in ERawExpression <$> normalizedRawSource fn:args -> EFunctionApplication <$> (FunctionApplication <$> normalizeExpression fn <*> @@ -79,16 +93,17 @@ normalizeExpression (Parse.Symbol symbol) = pure $ EIdentifier symbol normalizeFunctionDefinition :: - (MonadError Error m) + (Member (Effs.Error Error) effs) => Identifier -> [Parse.Expression] -> Parse.Expression - -> m FunctionDefinition + -> Eff effs FunctionDefinition normalizeFunctionDefinition fnName arguments body = FunctionDefinition fnName <$> traverse normalizeExpression arguments <*> normalizeExpression body -normalizeStatement :: (MonadError Error m) => Parse.Expression -> m Statement +normalizeStatement :: + (Member (Effs.Error Error) effs) => Parse.Expression -> Eff effs Statement normalizeStatement expr@(Parse.SExpression items) = case items of [Parse.Symbol "::", Parse.Symbol fnName, typeDef] -> @@ -98,6 +113,27 @@ Parse.Symbol "begin":stmts -> let normalizedStmts = traverse normalizeStatement stmts in STopLevel . TopLevel <$> normalizedStmts + Parse.Symbol "class":classConstraints:className:sigs -> + let normalizedConstraints = + normalizeExpression classConstraints >>= \case + EFunctionApplication (FunctionApplication (EIdentifier "list") constraints) -> + pure constraints + _ -> + throwError $ + NormalizeError "Invalid constraints!" [classConstraints, expr] + normalizedSigs = + traverse + (\x -> + normalizeStatement x >>= \case + STypeSignature tySig -> pure tySig + _ -> + throwError $ + NormalizeError "Invalid type signature!" [x, expr]) + sigs + in STypeclassDefinition <$> + (TypeclassDefinition <$> normalizeExpression className <*> + normalizedConstraints <*> + normalizedSigs) Parse.Symbol "data":typeDef:constructors -> let normalizedConstructors = traverse @@ -119,9 +155,6 @@ (DataDeclaration (ProperType properType) <$> normalizedConstructors) _ -> throwError $ NormalizeError "Invalid type!" [typeDef, expr] - [Parse.Symbol "macro", Parse.Symbol macroName, Parse.SExpression arguments, body] -> - SMacroDefinition . MacroDefinition <$> - normalizeFunctionDefinition macroName arguments body [Parse.Symbol "import", Parse.Symbol moduleName, importSpec] -> SRestrictedImport <$> (RestrictedImport moduleName <$> normalizeImportSpec expr importSpec) @@ -144,8 +177,21 @@ normalizedDefs) [Parse.Symbol "pragma", Parse.LiteralString pragma] -> pure $ SPragma (Pragma pragma) + [Parse.Symbol "macro", Parse.Symbol macroName, Parse.SExpression arguments, body] -> + SMacroDefinition . MacroDefinition <$> + normalizeFunctionDefinition macroName arguments body [Parse.Symbol "module", Parse.Symbol moduleName] -> pure $ SModuleDeclaration moduleName + [Parse.Symbol "raw", rawSource] -> + let normalizedRawSource = + case rawSource of + Parse.LiteralString x -> pure x + x -> + throwError $ + NormalizeError + "`raw` takes strings representing the code to inject directly." + [x, expr] + in SRawStatement <$> normalizedRawSource [Parse.Symbol "type", alias, def] -> let normalizedAlias = normalizeExpression alias normalizedDef = normalizeExpression def diff --git a/src/Axel/Parse.hs b/src/Axel/Parse.hs --- a/src/Axel/Parse.hs +++ b/src/Axel/Parse.hs @@ -27,7 +27,9 @@ ( Recursive(bottomUpFmap, bottomUpTraverse, topDownFmap) ) -import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Freer (Eff, Member) +import Control.Monad.Freer.Error (throwError) +import qualified Control.Monad.Freer.Error as Effs (Error) import Text.Parsec (ParsecT, Stream, (<|>), eof, parse, try) import Text.Parsec.Char @@ -157,7 +159,8 @@ '\\' -> "\\\\" c -> [c] -parseMultiple :: (MonadError Error m) => String -> m [Expression] +parseMultiple :: + (Member (Effs.Error Error) effs) => String -> Eff effs [Expression] parseMultiple = either (throwError . ParseError . show) (pure . map expandQuotes) . parse @@ -170,7 +173,7 @@ SExpression [Symbol "quote", x] -> quoteParseExpression x x -> x) -parseSingle :: (MonadError Error m) => String -> m Expression +parseSingle :: (Member (Effs.Error Error) effs) => String -> Eff effs Expression parseSingle input = parseMultiple input >>= \case [x] -> pure x @@ -181,7 +184,7 @@ where cleanLine = takeUntil "--" -parseSource :: (MonadError Error m) => String -> m Expression +parseSource :: (Member (Effs.Error Error) effs) => String -> Eff effs Expression parseSource input = do statements <- parseMultiple $ stripComments input pure $ SExpression (Symbol "begin" : statements) diff --git a/src/Axel/Parse/AST.hs b/src/Axel/Parse/AST.hs --- a/src/Axel/Parse/AST.hs +++ b/src/Axel/Parse/AST.hs @@ -6,6 +6,7 @@ module Axel.Parse.AST where import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +import Data.Semigroup ((<>)) import System.IO.Unsafe (unsafePerformIO) @@ -26,8 +27,8 @@ toAxel :: Expression -> String toAxel (LiteralChar x) = ['{', x, '}'] toAxel (LiteralInt x) = show x -toAxel (LiteralString xs) = "\"" ++ xs ++ "\"" -toAxel (SExpression xs) = "(" ++ unwords (map toAxel xs) ++ ")" +toAxel (LiteralString xs) = "\"" <> xs <> "\"" +toAxel (SExpression xs) = "(" <> unwords (map toAxel xs) <> ")" toAxel (Symbol x) = x -- ****************************** @@ -40,7 +41,7 @@ gensym :: IO Expression gensym = do suffix <- readIORef gensymCounter - let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" ++ show suffix + let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" <> show suffix modifyIORef gensymCounter succ pure $ Symbol identifier diff --git a/src/Axel/Parse/Args.hs b/src/Axel/Parse/Args.hs --- a/src/Axel/Parse/Args.hs +++ b/src/Axel/Parse/Args.hs @@ -13,12 +13,13 @@ , subparser ) -data ModeCommand +data Command = File FilePath | Project + | Version -modeCommandParser :: Parser ModeCommand -modeCommandParser = subparser $ projectCommand <> fileCommand +commandParser :: Parser Command +commandParser = subparser $ projectCommand <> fileCommand <> versionCommand where fileCommand = command @@ -29,3 +30,8 @@ command "project" (info (pure Project) $ progDesc "Build and run the project") + versionCommand = + command + "version" + (info (pure Version) $ + progDesc "Display the version of the Axel compiler") diff --git a/test/Axel/Test/ASTGen.hs b/test/Axel/Test/ASTGen.hs --- a/test/Axel/Test/ASTGen.hs +++ b/test/Axel/Test/ASTGen.hs @@ -100,6 +100,12 @@ genTopLevel :: (MonadGen m) => m AST.TopLevel genTopLevel = AST.TopLevel <$> Gen.list (Range.linear 0 3) genStatement +genTypeclassDefinition :: (MonadGen m) => m AST.TypeclassDefinition +genTypeclassDefinition = + AST.TypeclassDefinition <$> genExpression <*> + Gen.list (Range.linear 0 3) genExpression <*> + Gen.list (Range.linear 0 3) genTypeSignature + genTypeclassInstance :: (MonadGen m) => m AST.TypeclassInstance genTypeclassInstance = AST.TypeclassInstance <$> genExpression <*> @@ -122,6 +128,7 @@ , AST.SModuleDeclaration <$> genIdentifier , AST.SQualifiedImport <$> genQualifiedImport , AST.SRestrictedImport <$> genRestrictedImport + , AST.STypeclassDefinition <$> genTypeclassDefinition , AST.STypeclassInstance <$> genTypeclassInstance , AST.STypeSignature <$> genTypeSignature , AST.STypeSynonym <$> genTypeSynonym diff --git a/test/Axel/Test/DenormalizeSpec.hs b/test/Axel/Test/DenormalizeSpec.hs --- a/test/Axel/Test/DenormalizeSpec.hs +++ b/test/Axel/Test/DenormalizeSpec.hs @@ -1,20 +1,32 @@ +{-# LANGUAGE TypeApplications #-} + module Axel.Test.DenormalizeSpec where import Axel.Denormalize +import Axel.Error import Axel.Normalize import qualified Axel.Test.ASTGen as ASTGen import Axel.Test.MockUtils +import Control.Monad.Freer as Eff +import Control.Monad.Freer.Error (runError) + import Hedgehog hprop_normalizeExpression_is_the_inverse_of_denormalizeExpression :: Property hprop_normalizeExpression_is_the_inverse_of_denormalizeExpression = property $ do expr <- forAll ASTGen.genExpression - expr === unwrapRight (normalizeExpression (denormalizeExpression expr)) + expr === + unwrapRight + (Eff.run . runError @Error $ + normalizeExpression (denormalizeExpression expr)) hprop_normalizeStatement_is_the_inverse_of_denormalizeStatement :: Property hprop_normalizeStatement_is_the_inverse_of_denormalizeStatement = property $ do stmt <- forAll ASTGen.genStatement - stmt === unwrapRight (normalizeStatement (denormalizeStatement stmt)) + stmt === + unwrapRight + (Eff.run . runError @Error $ + normalizeStatement (denormalizeStatement stmt)) diff --git a/test/Axel/Test/Eff/ConsoleMock.hs b/test/Axel/Test/Eff/ConsoleMock.hs new file mode 100644 --- /dev/null +++ b/test/Axel/Test/Eff/ConsoleMock.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Axel.Test.Eff.ConsoleMock where + +import Axel.Eff.Console as Effs + +import Control.Lens +import Control.Monad.Freer +import Control.Monad.Freer.State as Effs + +newtype ConsoleState = ConsoleState + { _consoleOutput :: String + } deriving (Eq, Show) + +makeFieldsNoPrefix ''ConsoleState + +mkConsoleState :: ConsoleState +mkConsoleState = ConsoleState {_consoleOutput = ""} + +runConsole :: + forall effs a. + ConsoleState + -> Eff (Effs.Console ': effs) a + -> Eff effs (a, ConsoleState) +runConsole origState action = runState origState $ reinterpret go action + where + go :: Console b -> Eff (Effs.State ConsoleState ': effs) b + go (PutStr str) = modify @ConsoleState $ consoleOutput %~ (<> str) diff --git a/test/Axel/Test/Eff/ConsoleSpec.hs b/test/Axel/Test/Eff/ConsoleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Axel/Test/Eff/ConsoleSpec.hs @@ -0,0 +1,20 @@ +module Axel.Test.Eff.ConsoleSpec where + +import qualified Axel.Eff.Console as Console +import qualified Axel.Test.Eff.ConsoleMock as Mock + +import Control.Monad.Freer as Eff + +import Test.Tasty.Hspec + +{-# ANN module "HLint: ignore Redundant do" #-} + +spec_Console :: SpecWith () +spec_Console = + describe "putStrLn" $ do + it "prints to the console with a trailing newline" $ do + let action = Console.putStrLn "line1\nline2" + let origState = Mock.mkConsoleState + let expected = Mock.ConsoleState {Mock._consoleOutput = "line1\nline2\n"} + let result = Eff.run . Mock.runConsole origState $ action + result `shouldBe` ((), expected) diff --git a/test/Axel/Test/Eff/FileSystemMock.hs b/test/Axel/Test/Eff/FileSystemMock.hs new file mode 100644 --- /dev/null +++ b/test/Axel/Test/Eff/FileSystemMock.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Axel.Test.Eff.FileSystemMock where + +import Axel.Eff.FileSystem as Effs +import Axel.Test.MockUtils + +import Control.Lens hiding (children) +import Control.Monad.Freer +import Control.Monad.Freer.Error as Effs +import Control.Monad.Freer.State as Effs + +import Data.List.Split +import Data.Maybe + +import System.FilePath + +data FSNode + = Directory FilePath + [FSNode] + | File FilePath + String + deriving (Eq, Show) + +fsPath :: Lens' FSNode FilePath +fsPath = + lens + (\case + Directory path _ -> path + File path _ -> path) + (\node newPath -> + case node of + Directory _ children -> Directory newPath children + File _ contents -> File newPath contents) + +data FileSystemState = FileSystemState + { _fsCurrentDirectory :: FilePath + , _fsRoot :: FSNode + , _fsTempCounter :: Int + } deriving (Eq, Show) + +makeFieldsNoPrefix ''FileSystemState + +mkFileSystemState :: [FSNode] -> FileSystemState +mkFileSystemState rootContents = + FileSystemState + { _fsCurrentDirectory = "/" + , _fsRoot = Directory "/" rootContents + , _fsTempCounter = 0 + } + +lookupNode :: [FilePath] -> FSNode -> Maybe FSNode +lookupNode _ (File _ _) = Nothing +lookupNode [] _ = Nothing +lookupNode ["."] rootNode = pure rootNode +lookupNode [segment] (Directory _ rootChildren) = + let matchingChildren = + filter (\child -> child ^. fsPath == segment) rootChildren + in case matchingChildren of + [child] -> pure child + _ -> Nothing +lookupNode (segment:xs) rootNode@(Directory _ _) = do + child@(Directory _ _) <- lookupNode [segment] rootNode + lookupNode xs child + +deleteNode :: [FilePath] -> FSNode -> Maybe FSNode +deleteNode _ (File _ _) = Nothing +deleteNode [] _ = Nothing +deleteNode [segment] rootNode@(Directory rootPath rootChildren) = do + child <- lookupNode [segment] rootNode + let rootChildren' = filter (/= child) rootChildren + pure $ Directory rootPath rootChildren' +deleteNode (segment:xs) rootNode@(Directory rootPath rootChildren) = do + needle <- lookupNode [segment] rootNode + rootChildren' <- + mapM + (\child -> + case child of + File _ _ -> pure child + _ -> + if child == needle + then deleteNode xs child + else pure child) + rootChildren + pure $ Directory rootPath rootChildren' + +insertNode :: [FilePath] -> FSNode -> FSNode -> Maybe FSNode +insertNode _ _ (File _ _) = Nothing +insertNode [] _ _ = Nothing +insertNode [segment] newNode (Directory rootPath rootChildren) = + if newNode ^. fsPath == segment + then let rootChildren' = + filter + (\child -> child ^. fsPath /= newNode ^. fsPath) + rootChildren + in pure $ Directory rootPath (newNode : rootChildren') + else Nothing +insertNode (segment:xs) newNode rootNode@(Directory rootPath rootChildren) = do + needle <- lookupNode [segment] rootNode + rootChildren' <- + mapM + (\child -> + case child of + File _ _ -> pure child + _ -> + if child == needle + then insertNode xs newNode child + else pure child) + rootChildren + pure $ Directory rootPath rootChildren' + +type instance Index FSNode = FilePath + +type instance IxValue FSNode = FSNode + +instance Ixed FSNode where + ix :: + (Applicative f) => FilePath -> (FSNode -> f FSNode) -> FSNode -> f FSNode + ix path f root = + case lookupNode pathSegments root of + Just node -> + f node <&> \newNode -> fromJust $ insertNode pathSegments newNode root + Nothing -> pure root + where + pathSegments :: [FilePath] + pathSegments = splitDirectories path + +instance At FSNode where + at :: FilePath -> Lens' FSNode (Maybe FSNode) + at path = + let setter :: FSNode -> Maybe FSNode -> FSNode + setter root = + fromMaybe root . \case + Just newNode -> insertNode pathSegments newNode root + Nothing -> deleteNode pathSegments root + in lens (lookupNode pathSegments) setter + where + pathSegments :: [FilePath] + pathSegments = splitDirectories path + +absifyPath :: FilePath -> FilePath -> FilePath +absifyPath relativePath currentDirectory = + let absolutePath = + case relativePath of + '/':_ -> relativePath + _ -> "/" currentDirectory relativePath + normalizedSegments = + concatMap + (\case + [_, ".."] -> [] + ["."] -> [] + xs -> xs) $ + chunksOf 2 $ + dropLeadingSlash $ + splitDirectories absolutePath + in case joinPath normalizedSegments of + "" -> "/" + path -> path + where + dropLeadingSlash ("/":xs) = xs + dropLeadingSlash xs = xs + +absify :: + (Member (Effs.State FileSystemState) effs) => FilePath -> Eff effs FilePath +absify relativePath = + absifyPath relativePath <$> gets @FileSystemState (^. fsCurrentDirectory) + +runFileSystem :: + forall effs a. (Member (Effs.Error String) effs) + => FileSystemState + -> Eff (Effs.FileSystem ': effs) a + -> Eff effs (a, FileSystemState) +runFileSystem origState = runState origState . reinterpret go + where + go :: FileSystem ~> Eff (Effs.State FileSystemState ': effs) + go (CopyFile src dest) = do + contents <- go $ ReadFile src + go $ WriteFile contents dest + go (CreateDirectoryIfMissing createParents relativePath) = do + path <- absify relativePath + parentNode <- gets @FileSystemState (^. fsRoot . at (takeDirectory path)) + case parentNode of + Just _ -> + modify @FileSystemState $ fsRoot . at path ?~ + Directory (takeFileName path) [] + Nothing -> + if createParents + then modify @FileSystemState $ fsRoot %~ \origRoot -> + fst + (foldl + (\(root, segments) pathSegment -> + let newSegments = segments <> [pathSegment] + newRoot = + case root ^. at (joinPath newSegments) of + Just _ -> root + Nothing -> + root & at (joinPath newSegments) ?~ + Directory pathSegment [] + in (newRoot, newSegments)) + (origRoot, []) + (splitDirectories path)) + else throwInterpretError + @FileSystemState + "createDirectoryIfMissing" + ("Missing parents for directory: " <> path) + go (DoesDirectoryExist relativePath) = do + path <- absify relativePath + directoryNode <- gets @FileSystemState (^. fsRoot . at path) + pure $ + case directoryNode of + Just (Directory _ _) -> True + _ -> False + go GetCurrentDirectory = gets @FileSystemState (^. fsCurrentDirectory) + go (GetDirectoryContents relativePath) = do + path <- absify relativePath + directoryNode <- gets @FileSystemState (^. fsRoot . at path) + case directoryNode of + Just (Directory _ children) -> pure $ map (^. fsPath) children + _ -> + throwInterpretError + @FileSystemState + "getDirectoryContents" + ("No such directory: " <> path) + go GetTemporaryDirectory = do + tempCounter <- gets @FileSystemState (^. fsTempCounter) + modify @FileSystemState $ fsTempCounter %~ (+ 1) + let tempDirName = "/tmp" show tempCounter + go $ CreateDirectoryIfMissing True tempDirName + pure tempDirName + go (ReadFile relativePath) = do + path <- absify relativePath + fileNode <- gets @FileSystemState (^. fsRoot . at path) + case fileNode of + Just (File _ contents) -> pure contents + _ -> + throwInterpretError + @FileSystemState + "readFile" + ("No such file: " <> path) + go (RemoveFile relativePath) = do + path <- absify relativePath + gets @FileSystemState (deleteNode (splitDirectories path) . (^. fsRoot)) >>= \case + Just newRoot -> modify @FileSystemState $ fsRoot .~ newRoot + Nothing -> + throwInterpretError + @FileSystemState + "removeFile" + ("No such file: " <> path) + go (SetCurrentDirectory relativePath) = do + path <- absify relativePath + modify @FileSystemState $ fsCurrentDirectory .~ path + go (WriteFile relativePath contents) = do + path <- absify relativePath + modify @FileSystemState $ fsRoot . at path ?~ + File (takeFileName path) contents diff --git a/test/Axel/Test/Eff/FileSystemSpec.hs b/test/Axel/Test/Eff/FileSystemSpec.hs new file mode 100644 --- /dev/null +++ b/test/Axel/Test/Eff/FileSystemSpec.hs @@ -0,0 +1,76 @@ +module Axel.Test.Eff.FileSystemSpec where + +import qualified Axel.Eff.FileSystem as FS +import qualified Axel.Test.Eff.FileSystemMock as Mock + +import Control.Lens +import Control.Monad.Freer as Eff +import Control.Monad.Freer.Error + +import System.FilePath + +import Test.Tasty.Hspec + +{-# ANN module "HLint: ignore Redundant do" #-} + +spec_FileSystem :: SpecWith () +spec_FileSystem = do + describe "getDirectoryContentsRec" $ do + it "gets the files inside a directory and all its subdirectories" $ do + let action = FS.getDirectoryContentsRec "dir1" + let origState = + Mock.mkFileSystemState + [ Mock.Directory + "dir1" + [ Mock.File "file1" "" + , Mock.Directory + "dir2" + [Mock.File "file2" "", Mock.Directory "dir3" []] + ] + ] + let expected = ["dir1/file1", "dir1/dir2/file2"] + case Eff.run . runError . Mock.runFileSystem origState $ action of + Left err -> expectationFailure err + Right result -> result `shouldBe` (expected, origState) + describe "withCurrentDirectory" $ do + it "changes the directory and resets it afterwards" $ do + let action = do + FS.withCurrentDirectory "inside/subdir" $ + FS.writeFile "insideDir" "insideDirContents" + FS.writeFile "outsideDir" "outsideDirContents" + let origState = + Mock.mkFileSystemState + [ Mock.Directory + "inside" + [ Mock.Directory "subdir" [Mock.File "bar" "barContents"] + , Mock.File "foo" "fooContents" + ] + ] + let expected = + origState & + (Mock.fsRoot . at "inside/subdir/insideDir" ?~ + Mock.File "insideDir" "insideDirContents") & + (Mock.fsRoot . at "outsideDir" ?~ + Mock.File "outsideDir" "outsideDirContents") + case Eff.run . runError . Mock.runFileSystem origState $ action of + Left err -> expectationFailure err + Right result -> result `shouldBe` ((), expected) + describe "withTemporaryDirectory" $ do + it + "creates a temporary directory and resets the current directory afterwards" $ do + let action = do + FS.withTemporaryDirectory $ \tempDir -> + FS.writeFile (tempDir "insideTemp0") "insideTemp0Contents" + FS.withTemporaryDirectory $ \tempDir -> + FS.writeFile (tempDir "insideTemp1") "insideTemp1Contents" + let origState = Mock.mkFileSystemState [] + let expected = + origState & (Mock.fsRoot . at "tmp" ?~ Mock.Directory "tmp" []) & + (Mock.fsRoot . at "tmp/0" ?~ + Mock.Directory "0" [Mock.File "insideTemp0" "insideTemp0Contents"]) & + (Mock.fsRoot . at "tmp/1" ?~ + Mock.Directory "1" [Mock.File "insideTemp1" "insideTemp1Contents"]) & + (Mock.fsTempCounter .~ 2) + case Eff.run . runError . Mock.runFileSystem origState $ action of + Left err -> expectationFailure err + Right result -> result `shouldBe` ((), expected) diff --git a/test/Axel/Test/Eff/ProcessMock.hs b/test/Axel/Test/Eff/ProcessMock.hs new file mode 100644 --- /dev/null +++ b/test/Axel/Test/Eff/ProcessMock.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Axel.Test.Eff.ProcessMock where + +import Axel.Eff.FileSystem as Effs +import Axel.Eff.Process as Effs +import Axel.Test.MockUtils + +import Control.Lens +import Control.Monad.Freer as Eff +import Control.Monad.Freer.Error as Effs +import Control.Monad.Freer.State as Effs + +import Data.Functor + +import System.Exit + +newtype ProcessResult effs = + ProcessResult ((ExitCode, Maybe (String, String)), Eff effs ()) + +-- | We are pretending that all `ProcessResult`s are unique no matter what, for simplicity's sake. +instance Eq (ProcessResult effs) where + (==) :: ProcessResult effs -> ProcessResult effs -> Bool + _ == _ = False + +-- | We are pretending that all `ProcessResult`s are unique no matter what, for simplicity's sake. +instance Show (ProcessResult effs) where + show :: ProcessResult effs -> String + show _ = "" + +data ProcessState effs = ProcessState + { _procMockArgs :: [String] + , _procExecutionLog :: [(String, [String], Maybe String)] + , _procMockResults :: [ProcessResult effs] + } deriving (Eq, Show) + +makeFieldsNoPrefix ''ProcessState + +mkProcessState :: [String] -> [ProcessResult effs] -> ProcessState effs +mkProcessState mockArgs mockResults = + ProcessState + { _procMockArgs = mockArgs + , _procExecutionLog = [] + , _procMockResults = mockResults + } + +runProcess :: + forall effs a. (Members '[ Effs.Error String, Effs.FileSystem] effs) + => ProcessState effs + -> Eff (Effs.Process ': effs) a + -> Eff effs (a, ProcessState effs) +runProcess origProcessState = runState origProcessState . reinterpret go + where + go :: Process ~> Eff (Effs.State (ProcessState effs) ': effs) + go GetArgs = gets @(ProcessState effs) (^. procMockArgs) + go (RunProcessCreatingStreams cmd args stdin) = do + modify @(ProcessState effs) $ + procExecutionLog %~ (|> (cmd, args, Just stdin)) + gets @(ProcessState effs) (uncons . (^. procMockResults)) >>= \case + Just (ProcessResult (mockResult, fsAction), newMockResults) -> do + modify @(ProcessState effs) $ procMockResults .~ newMockResults + case mockResult of + (exitCode, Just (stdout, stderr)) -> + raise fsAction $> (exitCode, stdout, stderr) + _ -> + throwInterpretError + @(ProcessState effs) + "RunProcess" + ("Wrong type for mock result: " <> show mockResult) + Nothing -> + throwInterpretError + @(ProcessState effs) + "runProcess" + "No mock result available" + go (RunProcessInheritingStreams cmd args) = do + modify @(ProcessState effs) $ + procExecutionLog %~ (|> (cmd, args, Nothing)) + gets @(ProcessState effs) (uncons . (^. procMockResults)) >>= \case + Just (ProcessResult (mockResult, fsAction), newMockResults) -> do + modify @(ProcessState effs) $ procMockResults .~ newMockResults + case mockResult of + (exitCode, Nothing) -> raise fsAction $> exitCode + _ -> + throwInterpretError + @(ProcessState effs) + "RunProcessInheritingStreams" + ("Wrong type for mock result: " <> show mockResult) + Nothing -> + throwInterpretError + @(ProcessState effs) + "RunProcessInheritingStreams" + "No mock result available" diff --git a/test/Axel/Test/Eff/ResourceMock.hs b/test/Axel/Test/Eff/ResourceMock.hs new file mode 100644 --- /dev/null +++ b/test/Axel/Test/Eff/ResourceMock.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Axel.Test.Eff.ResourceMock where + +import Axel.Eff.Resource as Effs + +import Control.Monad.Freer + +import System.FilePath + +runResource :: forall effs a. Eff (Effs.Resource ': effs) a -> Eff effs a +runResource = + interpret $ \case + GetResourcePath (ResourceId resourceId) -> pure ("resources" resourceId) diff --git a/test/Axel/Test/Eff/ResourceSpec.hs b/test/Axel/Test/Eff/ResourceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Axel/Test/Eff/ResourceSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Axel.Test.Eff.ResourceSpec where + +import Axel.Eff.Resource as Res +import Axel.Test.Eff.FileSystemMock as Mock +import Axel.Test.Eff.ResourceMock as Mock + +import Control.Monad.Freer as Eff +import qualified Control.Monad.Freer.Error as Effs + +import Test.Tasty.Hspec + +{-# ANN module "HLint: ignore Redundant do" #-} + +spec_Resource :: SpecWith () +spec_Resource = + describe "readResource" $ do + it "reads a resource's contents from the file system" $ do + let action = Res.readResource (Res.ResourceId "resGroup1/res1") + let origFSState = + Mock.mkFileSystemState + [ Mock.Directory + "resources" + [Mock.Directory "resGroup1" [Mock.File "res1" "res1Contents"]] + ] + let expected = "res1Contents" + case Eff.run . + Effs.runError . Mock.runFileSystem origFSState . Mock.runResource $ + action of + Left err -> expectationFailure err + Right result -> result `shouldBe` (expected, origFSState) diff --git a/test/Axel/Test/File/FileSpec.hs b/test/Axel/Test/File/FileSpec.hs --- a/test/Axel/Test/File/FileSpec.hs +++ b/test/Axel/Test/File/FileSpec.hs @@ -1,9 +1,16 @@ +{-# LANGUAGE TypeApplications #-} + module Axel.Test.File.FileSpec where +import Axel.Eff.Console as Console +import Axel.Eff.FileSystem as FS +import Axel.Eff.Process as Proc +import Axel.Eff.Resource as Res import Axel.Error as Error import Axel.Haskell.File -import Axel.Monad.FileSystem as FS +import Control.Monad.Freer as Effs + import Data.ByteString.Lazy.Char8 as C import System.FilePath @@ -22,4 +29,8 @@ goldenVsString (takeBaseName axelFile) hsFile - (C.pack <$> Error.toIO (FS.readFile axelFile >>= transpileSource)) + (C.pack <$> + (Effs.runM . + Res.runEff . + Proc.runEff . FS.runEff . Error.runEff @Error . Console.runEff) + (FS.readFile axelFile >>= transpileSource)) diff --git a/test/Axel/Test/Haskell/GHCSpec.hs b/test/Axel/Test/Haskell/GHCSpec.hs deleted file mode 100644 --- a/test/Axel/Test/Haskell/GHCSpec.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Axel.Test.Haskell.GHCSpec where - -import Axel.Haskell.GHC as GHC -import Axel.Haskell.Stack as Stack -import qualified Axel.Test.Monad.FileSystemMock as Mock -import qualified Axel.Test.Monad.ProcessMock as Mock - -import Control.Lens -import Control.Monad.Except - -import System.Exit - -import Test.Tasty.Hspec - -{-# ANN module "HLint: ignore Redundant do" #-} - -spec_GHC :: SpecWith () -spec_GHC = do - describe "ghcCompile" $ do - it "compiles a file with GHC" $ do - let action = GHC.ghcCompile "projectFoo/app/Main.hs" - let origFSState = Mock.mkFSState [] - let origProcState = - Mock.mkProcessState - [] - [ Mock.ProcessResultT - ((ExitSuccess, Just ("testStdout", "")), pure ()) - ] - let expectation stdout (procState, _) = do - stdout `shouldBe` "testStdout" - procState ^. Mock.procExecutionLog `shouldBe` - [ ( "stack" - , [ "--resolver" - , Stack.stackageResolverWithAxel - , "ghc" - , "--" - , "-v0" - , "-ddump-json" - , "projectFoo/app/Main.hs" - ] - , Just "") - ] - case Mock.runProcess (origProcState, origFSState) $ runExceptT action of - Left err -> expectationFailure err - Right (Left err, _) -> expectationFailure err - Right (Right x, state) -> expectation x state - describe "ghcInterpret" $ do - it "interprets a file with GHC" $ do - let action = GHC.ghcInterpret "projectFoo/app/Main.hs" - let origFSState = Mock.mkFSState [] - let origProcState = - Mock.mkProcessState - [] - [ Mock.ProcessResultT - ((ExitSuccess, Just ("testStdout", "")), pure ()) - ] - let expectation stdout (procState, _) = do - stdout `shouldBe` "testStdout" - procState ^. Mock.procExecutionLog `shouldBe` - [ ( "stack" - , [ "--resolver" - , stackageResolverWithAxel - , "runghc" - , "--package" - , axelStackageId - , "--" - , "projectFoo/app/Main.hs" - ] - , Just "") - ] - case Mock.runProcess (origProcState, origFSState) $ runExceptT action of - Left err -> expectationFailure err - Right (Left err, _) -> expectationFailure err - Right (Right x, state) -> expectation x state diff --git a/test/Axel/Test/Haskell/StackSpec.hs b/test/Axel/Test/Haskell/StackSpec.hs --- a/test/Axel/Test/Haskell/StackSpec.hs +++ b/test/Axel/Test/Haskell/StackSpec.hs @@ -1,16 +1,23 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Axel.Test.Haskell.StackSpec where +import Axel.Eff.FileSystem as FS +import Axel.Eff.Process +import Axel.Error import Axel.Haskell.Stack as Stack -import Axel.Monad.FileSystem as FS -import Axel.Test.Monad.ConsoleMock as Mock -import Axel.Test.Monad.FileSystemMock as Mock -import Axel.Test.Monad.ProcessMock as Mock +import Axel.Test.Eff.ConsoleMock as Mock +import Axel.Test.Eff.FileSystemMock as Mock +import Axel.Test.Eff.ProcessMock as Mock import Control.Lens -import Control.Monad.Except +import Control.Monad.Freer as Eff +import qualified Control.Monad.Freer.Error as Effs import System.Exit @@ -24,7 +31,7 @@ it "adds a Stackage dependency to a Stack project" $ do let action = Stack.addStackDependency "foo-1.2.3.4" "project/path" let origFSState = - Mock.mkFSState + Mock.mkFileSystemState [ Mock.Directory "project" [ Mock.Directory @@ -37,40 +44,49 @@ Mock.File "package.yaml" "dependencies:\n- foo-1.2.3.4\n- asdf-5.6.7\n" - case Mock.runFileSystem origFSState action of + case Eff.run . Effs.runError . Mock.runFileSystem origFSState $ action of Left err -> expectationFailure err Right ((), result) -> result `shouldBe` expectedFSState describe "buildStackProject" $ do it "builds a Stack project" $ do - let action = Stack.buildStackProject "project/path" + let action = Stack.buildStackProject "project/foo" + let origConsoleState = Mock.mkConsoleState let origFSState = - Mock.mkFSState [Mock.Directory "project" [Mock.Directory "path" []]] + Mock.mkFileSystemState + [Mock.Directory "project" [Mock.Directory "foo" []]] let origProcState = Mock.mkProcessState [] - [ProcessResultT ((ExitSuccess, Just ("", "")), pure ())] - let expectation result (procState, fsState) = do + [ProcessResult ((ExitSuccess, Just ("", "")), pure ())] + let expectation result (consoleState, fsState, procState) = do result `shouldBe` () + consoleState ^. Mock.consoleOutput `shouldBe` "Building foo...\n" procState ^. Mock.procExecutionLog `shouldBe` [("stack", ["build"], Just "")] fsState ^. Mock.fsCurrentDirectory `shouldBe` "/" - case Mock.runProcess (origProcState, origFSState) $ runExceptT action of - Left err -> expectationFailure err - Right (Left err, _) -> expectationFailure $ show err - Right (Right x, state) -> expectation x state + case Eff.run . Effs.runError @Error . Effs.runError @String . + Mock.runFileSystem origFSState . + Mock.runProcess origProcState . + Mock.runConsole origConsoleState $ + action of + Left err -> expectationFailure $ show err + Right (Left err) -> expectationFailure err + Right (Right (((x, consoleState), procState), fsState)) -> + expectation x (consoleState, fsState, procState) describe "createStackProject" $ do it "creates a new Stack project" $ do let action = Stack.createStackProject "newProject" - let origFSState = Mock.mkFSState [] + let origFSState = Mock.mkFileSystemState [] let origProcState = Mock.mkProcessState [] - [ ProcessResultT + [ ProcessResult ( (ExitSuccess, Just ("", "")) , FS.createDirectoryIfMissing False "newProject") - , ProcessResultT ((ExitSuccess, Just ("", "")), pure ()) + , ProcessResult ((ExitSuccess, Just ("", "")), pure ()) ] - let expectation ((), (procState, fsState)) = do + let expectation result (fsState, procState) = do + result `shouldBe` () procState ^. Mock.procExecutionLog `shouldBe` [ ("stack", ["new", "newProject", "new-template"], Just "") , ( "stack" @@ -80,25 +96,31 @@ fsState ^. Mock.fsCurrentDirectory `shouldBe` "/" fsState ^. Mock.fsRoot . at "newProject" . _Just . Mock.fsPath `shouldBe` "newProject" - case Mock.runProcess (origProcState, origFSState) action of - Left err -> expectationFailure err - Right result -> expectation result + case Eff.run . Effs.runError @Error . Effs.runError @String . + Mock.runFileSystem origFSState . + Mock.runProcess origProcState $ + action of + Left err -> expectationFailure $ show err + Right (Left err) -> expectationFailure err + Right (Right ((x, procState), fsState)) -> + expectation x (fsState, procState) describe "runStackProject" $ do it "runs a Stack project" $ do - let action = Stack.runStackProject "project/path" + let action = Stack.runStackProject "project/foo" let origConsoleState = Mock.mkConsoleState let origFSState = - Mock.mkFSState [Mock.Directory "project" [Mock.Directory "path" []]] + Mock.mkFileSystemState + [Mock.Directory "project" [Mock.Directory "foo" []]] let origProcState = Mock.mkProcessState [] - [ ProcessResultT + [ ProcessResult ( ( ExitSuccess , Just ("", "foo:lib\nfoo:exe:foo-exe\nfoo:test:foo-test")) , pure ()) - , ProcessResultT ((ExitSuccess, Nothing), pure ()) + , ProcessResult ((ExitSuccess, Nothing), pure ()) ] - let expectation result (consoleState, procState, fsState) = do + let expectation result (consoleState, fsState, procState) = do result `shouldBe` () procState ^. Mock.procExecutionLog `shouldBe` [ ("stack", ["ide", "targets"], Just "") @@ -106,10 +128,69 @@ ] fsState ^. Mock.fsCurrentDirectory `shouldBe` "/" consoleState ^. Mock.consoleOutput `shouldBe` "Running foo-exe...\n" - case Mock.runProcess (origProcState, origFSState) $ - Mock.runConsoleT origConsoleState $ - runExceptT action of + case Eff.run . Effs.runError @Error . Effs.runError @String . + Mock.runFileSystem origFSState . + Mock.runProcess origProcState . + Mock.runConsole origConsoleState $ + action of + Left err -> expectationFailure $ show err + Right (Left err) -> expectationFailure err + Right (Right (((x, consoleState), procState), fsState)) -> + expectation x (consoleState, fsState, procState) + describe "compileFile" $ do + it "compiles a file with GHC" $ do + let action = Stack.compileFile @'CreateStreams "projectFoo/app/Main.hs" "" + let origFSState = Mock.mkFileSystemState [] + let origProcState = + Mock.mkProcessState + [] + [ProcessResult ((ExitSuccess, Just ("testStdout", "")), pure ())] + let expectation stdout (procState, _) = do + stdout `shouldBe` "testStdout" + procState ^. Mock.procExecutionLog `shouldBe` + [ ( "stack" + , [ "ghc" + , "--resolver" + , Stack.stackageResolverWithAxel + , "--package" + , Stack.axelStackageId + , "--" + , "projectFoo/app/Main.hs" + ] + , Just "") + ] + case Eff.run . Effs.runError @String . Mock.runFileSystem origFSState . + Mock.runProcess origProcState $ + action of Left err -> expectationFailure err - Right ((Left err, _), _) -> expectationFailure $ show err - Right ((Right x, consoleState), (procState, fsState)) -> - expectation x (consoleState, procState, fsState) + Right (((_, stdout, _), procState), fsState) -> + expectation stdout (procState, fsState) + describe "interpretFile" $ do + it "interprets a file with GHC" $ do + let action = + Stack.interpretFile @'CreateStreams "projectFoo/app/Main.hs" "" + let origFSState = Mock.mkFileSystemState [] + let origProcState = + Mock.mkProcessState + [] + [ProcessResult ((ExitSuccess, Just ("testStdout", "")), pure ())] + let expectation stdout (procState, _) = do + stdout `shouldBe` "testStdout" + procState ^. Mock.procExecutionLog `shouldBe` + [ ( "stack" + , [ "runghc" + , "--resolver" + , Stack.stackageResolverWithAxel + , "--package" + , Stack.axelStackageId + , "--" + , "projectFoo/app/Main.hs" + ] + , Just "") + ] + case Eff.run . Effs.runError @String . Mock.runFileSystem origFSState . + Mock.runProcess origProcState $ + action of + Left err -> expectationFailure err + Right (((_, stdout, _), procState), fsState) -> + expectation stdout (procState, fsState) diff --git a/test/Axel/Test/MockUtils.hs b/test/Axel/Test/MockUtils.hs --- a/test/Axel/Test/MockUtils.hs +++ b/test/Axel/Test/MockUtils.hs @@ -1,21 +1,29 @@ {-# OPTIONS_GHC "-fno-warn-incomplete-patterns" #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Axel.Test.MockUtils where -import Control.Monad.Except -import Control.Monad.State.Lazy +import Control.Monad.Freer +import Control.Monad.Freer.Error as Effs +import Control.Monad.Freer.State as Effs import GHC.Exts (IsString(fromString)) import Language.Haskell.TH.Quote throwInterpretError :: - (MonadError String m, MonadState s m, Show s) => String -> String -> m a + forall s effs a. (Members '[ Effs.Error String, Effs.State s] effs, Show s) + => String + -> String + -> Eff effs a throwInterpretError actionName message = do errorMsg <- - gets $ \ctxt -> + gets @s $ \ctxt -> "\n----------\nACTION\t" <> actionName <> "\n\nMESSAGE\t" <> message <> "\n\nSTATE\t" <> show ctxt <> diff --git a/test/Axel/Test/Monad/ConsoleMock.hs b/test/Axel/Test/Monad/ConsoleMock.hs deleted file mode 100644 --- a/test/Axel/Test/Monad/ConsoleMock.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} - -module Axel.Test.Monad.ConsoleMock where - -import Axel.Monad.Console as Console -import Axel.Monad.FileSystem as FS -import Axel.Monad.Process as Proc -import Axel.Monad.Resource as Res - -import Control.Lens -import Control.Monad.State.Lazy - -newtype ConsoleState = ConsoleState - { _consoleOutput :: String - } deriving (Eq, Show) - -makeFieldsNoPrefix ''ConsoleState - -mkConsoleState :: ConsoleState -mkConsoleState = ConsoleState {_consoleOutput = ""} - -newtype ConsoleT m a = - ConsoleT (StateT ConsoleState m a) - deriving ( Functor - , Applicative - , Monad - , MonadTrans - , MonadFileSystem - , MonadProcess - , MonadResource - ) - -type Console = ConsoleT Identity - -instance (Monad m) => MonadConsole (ConsoleT m) where - putStr str = ConsoleT $ consoleOutput <>= str - -runConsoleT :: ConsoleState -> ConsoleT m a -> m (a, ConsoleState) -runConsoleT origState (ConsoleT x) = runStateT x origState - -runConsole :: ConsoleState -> Console a -> (a, ConsoleState) -runConsole origState x = runIdentity $ runConsoleT origState x diff --git a/test/Axel/Test/Monad/ConsoleSpec.hs b/test/Axel/Test/Monad/ConsoleSpec.hs deleted file mode 100644 --- a/test/Axel/Test/Monad/ConsoleSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Axel.Test.Monad.ConsoleSpec where - -import qualified Axel.Monad.Console as Console -import qualified Axel.Test.Monad.ConsoleMock as Mock - -import Test.Tasty.Hspec - -{-# ANN module "HLint: ignore Redundant do" #-} - -spec_Console :: SpecWith () -spec_Console = - describe "putStrLn" $ do - it "prints to the console with a trailing newline" $ do - let action = Console.putStrLn "line1\nline2" - let origState = Mock.mkConsoleState - let expected = Mock.ConsoleState {Mock._consoleOutput = "line1\nline2\n"} - case Mock.runConsoleT origState action of - Left err -> expectationFailure err - Right result -> result `shouldBe` ((), expected) diff --git a/test/Axel/Test/Monad/FileSystemMock.hs b/test/Axel/Test/Monad/FileSystemMock.hs deleted file mode 100644 --- a/test/Axel/Test/Monad/FileSystemMock.hs +++ /dev/null @@ -1,278 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Axel.Test.Monad.FileSystemMock where - -import Axel.Monad.Console as Console -import Axel.Monad.FileSystem as FS -import Axel.Monad.Process as Proc -import Axel.Monad.Resource as Res -import Axel.Test.MockUtils - -import Control.Lens hiding (children) -import Control.Monad.Except -import Control.Monad.State.Lazy - -import Data.List.Split -import Data.Maybe - -import System.FilePath - -data FSNode - = Directory FilePath - [FSNode] - | File FilePath - String - deriving (Eq, Show) - -fsPath :: Lens' FSNode FilePath -fsPath = - lens - (\case - Directory path _ -> path - File path _ -> path) - (\node newPath -> - case node of - Directory _ children -> Directory newPath children - File _ contents -> File newPath contents) - -data FSState = FSState - { _fsCurrentDirectory :: FilePath - , _fsRoot :: FSNode - , _fsTempCounter :: Int - } deriving (Eq, Show) - -makeFieldsNoPrefix ''FSState - -mkFSState :: [FSNode] -> FSState -mkFSState rootContents = - FSState - { _fsCurrentDirectory = "/" - , _fsRoot = Directory "/" rootContents - , _fsTempCounter = 0 - } - -lookupNode :: [FilePath] -> FSNode -> Maybe FSNode -lookupNode _ (File _ _) = Nothing -lookupNode [] _ = Nothing -lookupNode ["."] rootNode = pure rootNode -lookupNode [segment] (Directory _ rootChildren) = - let matchingChildren = - filter (\child -> child ^. fsPath == segment) rootChildren - in case matchingChildren of - [child] -> pure child - _ -> Nothing -lookupNode (segment:xs) rootNode@(Directory _ _) = do - child@(Directory _ _) <- lookupNode [segment] rootNode - lookupNode xs child - -deleteNode :: [FilePath] -> FSNode -> Maybe FSNode -deleteNode _ (File _ _) = Nothing -deleteNode [] _ = Nothing -deleteNode [segment] rootNode@(Directory rootPath rootChildren) = do - child <- lookupNode [segment] rootNode - let rootChildren' = filter (/= child) rootChildren - pure $ Directory rootPath rootChildren' -deleteNode (segment:xs) rootNode@(Directory rootPath rootChildren) = do - needle <- lookupNode [segment] rootNode - rootChildren' <- - mapM - (\child -> - case child of - File _ _ -> pure child - _ -> - if child == needle - then deleteNode xs child - else pure child) - rootChildren - pure $ Directory rootPath rootChildren' - -insertNode :: [FilePath] -> FSNode -> FSNode -> Maybe FSNode -insertNode _ _ (File _ _) = Nothing -insertNode [] _ _ = Nothing -insertNode [segment] newNode (Directory rootPath rootChildren) = - if newNode ^. fsPath == segment - then let rootChildren' = - filter - (\child -> child ^. fsPath /= newNode ^. fsPath) - rootChildren - in pure $ Directory rootPath (newNode : rootChildren') - else Nothing -insertNode (segment:xs) newNode rootNode@(Directory rootPath rootChildren) = do - needle <- lookupNode [segment] rootNode - rootChildren' <- - mapM - (\child -> - case child of - File _ _ -> pure child - _ -> - if child == needle - then insertNode xs newNode child - else pure child) - rootChildren - pure $ Directory rootPath rootChildren' - -type instance Index FSNode = FilePath - -type instance IxValue FSNode = FSNode - -instance Ixed FSNode where - ix :: - (Applicative f) => FilePath -> (FSNode -> f FSNode) -> FSNode -> f FSNode - ix path f root = - case lookupNode pathSegments root of - Just node -> - f node <&> \newNode -> fromJust $ insertNode pathSegments newNode root - Nothing -> pure root - where - pathSegments :: [FilePath] - pathSegments = splitDirectories path - -instance At FSNode where - at :: FilePath -> Lens' FSNode (Maybe FSNode) - at path = - let setter :: FSNode -> Maybe FSNode -> FSNode - setter root = - fromMaybe root . \case - Just newNode -> insertNode pathSegments newNode root - Nothing -> deleteNode pathSegments root - in lens (lookupNode pathSegments) setter - where - pathSegments :: [FilePath] - pathSegments = splitDirectories path - -absifyPath :: FilePath -> FilePath -> FilePath -absifyPath relativePath currentDirectory = - let absolutePath = - case relativePath of - '/':_ -> relativePath - _ -> "/" currentDirectory relativePath - normalizedSegments = - concatMap - (\case - [_, ".."] -> [] - ["."] -> [] - xs -> xs) $ - chunksOf 2 $ - dropLeadingSlash $ - splitDirectories absolutePath - in case joinPath normalizedSegments of - "" -> "/" - path -> path - where - dropLeadingSlash ("/":xs) = xs - dropLeadingSlash xs = xs - -absify :: (MonadState FSState f) => FilePath -> f FilePath -absify relativePath = absifyPath relativePath <$> gets (^. fsCurrentDirectory) - -newtype FileSystemT m a = - FileSystemT (StateT FSState (ExceptT String m) a) - deriving ( Functor - , Applicative - , Monad - , MonadConsole - , MonadProcess - , MonadResource - ) - -type FileSystem = FileSystemT Identity - -instance Eq (FileSystemT m a) where - _ == _ = False - -instance Show (FileSystemT m a) where - show _ = "" - -instance MonadTrans FileSystemT where - lift = FileSystemT . lift . lift - -instance (Monad m) => MonadFileSystem (FileSystemT m) where - copyFile src dest = do - contents <- FS.readFile src - FS.writeFile contents dest - createDirectoryIfMissing createParents relativePath = - FileSystemT $ do - path <- absify relativePath - parentNode <- gets (^. fsRoot . at (takeDirectory path)) - case parentNode of - Just _ -> fsRoot . at path ?= Directory (takeFileName path) [] - Nothing -> - if createParents - then fsRoot %= \origRoot -> - fst - (foldl - (\(root, segments) pathSegment -> - let newSegments = segments <> [pathSegment] - newRoot = - case root ^. at (joinPath newSegments) of - Just _ -> root - Nothing -> - root & at (joinPath newSegments) ?~ - Directory pathSegment [] - in (newRoot, newSegments)) - (origRoot, []) - (splitDirectories path)) - else throwInterpretError - "createDirectoryIfMissing" - ("Missing parents for directory: " <> path) - doesDirectoryExist relativePath = - FileSystemT $ do - path <- absify relativePath - directoryNode <- gets (^. fsRoot . at path) - pure $ - case directoryNode of - Just (Directory _ _) -> True - _ -> False - getCurrentDirectory = FileSystemT $ gets (^. fsCurrentDirectory) - getDirectoryContents relativePath = - FileSystemT $ do - path <- absify relativePath - directoryNode <- gets (^. fsRoot . at path) - case directoryNode of - Just (Directory _ children) -> pure $ map (^. fsPath) children - _ -> - throwInterpretError - "getDirectoryContents" - ("No such directory: " <> path) - getTemporaryDirectory = do - tempCounter <- FileSystemT $ fsTempCounter <<+= 1 - let tempDirName = "/tmp" show tempCounter - FS.createDirectoryIfMissing True tempDirName - pure tempDirName - readFile relativePath = - FileSystemT $ do - path <- absify relativePath - fileNode <- gets (^. fsRoot . at path) - case fileNode of - Just (File _ contents) -> pure contents - _ -> throwInterpretError "readFile" ("No such file: " <> path) - removeFile relativePath = - FileSystemT $ do - path <- absify relativePath - gets (deleteNode (splitDirectories path) . (^. fsRoot)) >>= \case - Just newRoot -> fsRoot .= newRoot - Nothing -> throwInterpretError "removeFile" ("No such file: " <> path) - setCurrentDirectory relativePath = - FileSystemT $ do - path <- absify relativePath - fsCurrentDirectory .= path - writeFile relativePath contents = - FileSystemT $ do - path <- absify relativePath - fsRoot . at path ?= File (takeFileName path) contents - -runFileSystemT :: FSState -> FileSystemT m a -> ExceptT String m (a, FSState) -runFileSystemT origState (FileSystemT x) = runStateT x origState - -runFileSystem :: FSState -> FileSystem a -> Either String (a, FSState) -runFileSystem origState x = runExcept $ runFileSystemT origState x diff --git a/test/Axel/Test/Monad/FileSystemSpec.hs b/test/Axel/Test/Monad/FileSystemSpec.hs deleted file mode 100644 --- a/test/Axel/Test/Monad/FileSystemSpec.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Axel.Test.Monad.FileSystemSpec where - -import qualified Axel.Monad.FileSystem as FS -import qualified Axel.Test.Monad.FileSystemMock as Mock - -import Control.Lens - -import System.FilePath - -import Test.Tasty.Hspec - -{-# ANN module "HLint: ignore Redundant do" #-} - -spec_FileSystem :: SpecWith () -spec_FileSystem = do - describe "getDirectoryContentsRec" $ do - it "gets the files inside a directory and all its subdirectories" $ do - let action = FS.getDirectoryContentsRec "dir1" - let origState = - Mock.mkFSState - [ Mock.Directory - "dir1" - [ Mock.File "file1" "" - , Mock.Directory - "dir2" - [Mock.File "file2" "", Mock.Directory "dir3" []] - ] - ] - let expected = ["dir1/file1", "dir1/dir2/file2"] - case Mock.runFileSystem origState action of - Left err -> expectationFailure err - Right result -> result `shouldBe` (expected, origState) - describe "withCurrentDirectory" $ do - it "changes the directory and resets it afterwards" $ do - let action = do - FS.withCurrentDirectory "inside/subdir" $ - FS.writeFile "insideDir" "insideDirContents" - FS.writeFile "outsideDir" "outsideDirContents" - let origState = - Mock.mkFSState - [ Mock.Directory - "inside" - [ Mock.Directory "subdir" [Mock.File "bar" "barContents"] - , Mock.File "foo" "fooContents" - ] - ] - let expected = - origState & - (Mock.fsRoot . at "inside/subdir/insideDir" ?~ - Mock.File "insideDir" "insideDirContents") & - (Mock.fsRoot . at "outsideDir" ?~ - Mock.File "outsideDir" "outsideDirContents") - case Mock.runFileSystem origState action of - Left err -> expectationFailure err - Right result -> result `shouldBe` ((), expected) - describe "withTemporaryDirectory" $ do - it - "creates a temporary directory and resets the current directory afterwards" $ do - let action = do - FS.withTemporaryDirectory $ \tempDir -> - FS.writeFile (tempDir "insideTemp0") "insideTemp0Contents" - FS.withTemporaryDirectory $ \tempDir -> - FS.writeFile (tempDir "insideTemp1") "insideTemp1Contents" - let origState = Mock.mkFSState [] - let expected = - origState & (Mock.fsRoot . at "tmp" ?~ Mock.Directory "tmp" []) & - (Mock.fsRoot . at "tmp/0" ?~ - Mock.Directory "0" [Mock.File "insideTemp0" "insideTemp0Contents"]) & - (Mock.fsRoot . at "tmp/1" ?~ - Mock.Directory "1" [Mock.File "insideTemp1" "insideTemp1Contents"]) & - (Mock.fsTempCounter .~ 2) - case Mock.runFileSystem origState action of - Left err -> expectationFailure err - Right result -> result `shouldBe` ((), expected) diff --git a/test/Axel/Test/Monad/ProcessMock.hs b/test/Axel/Test/Monad/ProcessMock.hs deleted file mode 100644 --- a/test/Axel/Test/Monad/ProcessMock.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} - -module Axel.Test.Monad.ProcessMock where - -import Axel.Monad.Console as Console -import Axel.Monad.FileSystem as FS -import Axel.Monad.Process as Proc -import Axel.Monad.Resource as Res -import Axel.Test.MockUtils -import Axel.Test.Monad.FileSystemMock as Mock - -import Control.Lens -import Control.Monad.Except -import Control.Monad.State.Lazy - -import System.Exit - -newtype ProcessResultT m = - ProcessResultT ((ExitCode, Maybe (String, String)), Mock.FileSystemT m ()) - deriving (Eq, Show) - -data ProcessStateT m = ProcessStateT - { _procMockArgs :: [String] - , _procExecutionLog :: [(String, [String], Maybe String)] - , _procMockResults :: [ProcessResultT m] - } deriving (Eq, Show) - -makeFieldsNoPrefix ''ProcessStateT - -type ProcessState = ProcessStateT Identity - -mkProcessState :: [String] -> [ProcessResultT m] -> ProcessStateT m -mkProcessState mockArgs mockResults = - ProcessStateT - { _procMockArgs = mockArgs - , _procExecutionLog = [] - , _procMockResults = mockResults - } - -newtype ProcessT m a = - ProcessT (StateT (ProcessStateT m) (ExceptT String (Mock.FileSystemT m)) a) - deriving ( Functor - , Applicative - , Monad - , MonadConsole - , MonadFileSystem - , MonadResource - ) - -type Process = ProcessT Identity - -deriving instance - (Eq - (StateT (ProcessStateT m) (ExceptT String (Mock.FileSystemT m)) - a)) => - Eq (ProcessT m a) - -deriving instance - (Show - (StateT (ProcessStateT m) (ExceptT String (Mock.FileSystemT m)) - a)) => - Show (ProcessT m a) - -instance MonadTrans ProcessT where - lift = ProcessT . lift . lift . lift - -instance (Monad m) => MonadProcess (ProcessT m) where - getArgs = ProcessT $ gets (^. procMockArgs) - runProcess cmd args stdin = - ProcessT $ do - procExecutionLog %= (|> (cmd, args, Just stdin)) - gets (uncons . (^. procMockResults)) >>= \case - Just (ProcessResultT (mockResult, fsAction), newMockResults) -> do - procMockResults .= newMockResults - case mockResult of - (exitCode, Just (stdout, stderr)) -> - lift (lift fsAction) >> pure (exitCode, stdout, stderr) - _ -> - throwInterpretError - "RunProcess" - ("Wrong type for mock result: " <> show mockResult) - Nothing -> throwInterpretError "runProcess" "No mock result available" - runProcessInheritingStreams cmd args = - ProcessT $ do - procExecutionLog %= (|> (cmd, args, Nothing)) - gets (uncons . (^. procMockResults)) >>= \case - Just (ProcessResultT (mockResult, fsAction), newMockResults) -> do - procMockResults .= newMockResults - case mockResult of - (exitCode, Nothing) -> pure fsAction >> pure exitCode - _ -> - throwInterpretError - "runProcessInheritingStreams" - ("Wrong type for mock result: " <> show mockResult) - Nothing -> - throwInterpretError - "RunProcessInheritingStreams" - "No mock result available" - -runProcessT :: - forall a m. (Monad m) - => (ProcessStateT m, Mock.FSState) - -> ProcessT m a - -> ExceptT String m (a, (ProcessStateT m, Mock.FSState)) -runProcessT (origState, origFSState) (ProcessT x) = - ExceptT $ - runExceptT (runFileSystemT origFSState $ runExceptT $ runStateT x origState) <&> \case - Left err -> Left err - Right (x'', fsState) -> - case x'' of - Left err -> Left err - Right (x''', procState) -> Right (x''', (procState, fsState)) - -runProcess :: - (ProcessState, Mock.FSState) - -> Process a - -> Either String (a, (ProcessState, Mock.FSState)) -runProcess origState x = runExcept $ runProcessT origState x diff --git a/test/Axel/Test/Monad/ResourceMock.hs b/test/Axel/Test/Monad/ResourceMock.hs deleted file mode 100644 --- a/test/Axel/Test/Monad/ResourceMock.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Axel.Test.Monad.ResourceMock where - -import Axel.Monad.Console as Console -import Axel.Monad.FileSystem as FS -import Axel.Monad.Process as Proc -import Axel.Monad.Resource as Res - -import Control.Monad.Identity -import Control.Monad.Trans - -import System.FilePath - -newtype ResourceT m a = - ResourceT (m a) - deriving ( Functor - , Applicative - , Monad - , MonadConsole - , MonadFileSystem - , MonadProcess - ) - -type Resource = ResourceT Identity - -instance MonadTrans ResourceT where - lift = ResourceT - -instance (Monad m) => MonadResource (ResourceT m) where - getResourcePath (Res.ResourceId resourceId) = - ResourceT $ pure ("resources" resourceId) - -runResourceT :: ResourceT m a -> m a -runResourceT (ResourceT x) = x - -runResource :: Resource a -> a -runResource = runIdentity . runResourceT diff --git a/test/Axel/Test/Monad/ResourceSpec.hs b/test/Axel/Test/Monad/ResourceSpec.hs deleted file mode 100644 --- a/test/Axel/Test/Monad/ResourceSpec.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Axel.Test.Monad.ResourceSpec where - -import qualified Axel.Monad.Resource as Res -import qualified Axel.Test.Monad.FileSystemMock as Mock -import qualified Axel.Test.Monad.ResourceMock as Mock - -import Test.Tasty.Hspec - -{-# ANN module "HLint: ignore Redundant do" #-} - -spec_Resource :: SpecWith () -spec_Resource = - describe "readResource" $ do - it "reads a resource's contents from the file system" $ do - let action = Res.readResource (Res.ResourceId "resGroup1/res1") - let origFSState = - Mock.mkFSState - [ Mock.Directory - "resources" - [Mock.Directory "resGroup1" [Mock.File "res1" "res1Contents"]] - ] - let expected = "res1Contents" - case Mock.runFileSystem origFSState $ Mock.runResourceT action of - Left err -> expectationFailure err - Right result -> result `shouldBe` (expected, origFSState) diff --git a/test/Axel/Test/NormalizeSpec.hs b/test/Axel/Test/NormalizeSpec.hs --- a/test/Axel/Test/NormalizeSpec.hs +++ b/test/Axel/Test/NormalizeSpec.hs @@ -1,14 +1,22 @@ +{-# LANGUAGE TypeApplications #-} + module Axel.Test.NormalizeSpec where import Axel.Denormalize +import Axel.Error import Axel.Normalize import Axel.Test.MockUtils import qualified Axel.Test.Parse.ASTGen as Parse.ASTGen +import Control.Monad.Freer as Eff +import qualified Control.Monad.Freer.Error as Effs + import Hedgehog hprop_denormalizeExpression_is_the_inverse_of_normalizeExpression :: Property hprop_denormalizeExpression_is_the_inverse_of_normalizeExpression = property $ do expr <- forAll Parse.ASTGen.genExpression - expr === denormalizeExpression (unwrapRight (normalizeExpression expr)) + expr === + denormalizeExpression + (unwrapRight $ Eff.run . Effs.runError @Error $ normalizeExpression expr) diff --git a/test/Axel/Test/ParseSpec.hs b/test/Axel/Test/ParseSpec.hs --- a/test/Axel/Test/ParseSpec.hs +++ b/test/Axel/Test/ParseSpec.hs @@ -1,45 +1,52 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} module Axel.Test.ParseSpec where +import Axel.Error import Axel.Parse import Axel.Test.MockUtils +import Control.Monad.Freer as Eff +import qualified Control.Monad.Freer.Error as Effs + import Test.Tasty.Hspec +{-# ANN module "HLint: ignore Redundant do" #-} + spec_Parse :: SpecWith () spec_Parse = do describe "parseSingle" $ do it "can parse a character literal" $ do let result = LiteralChar 'a' - case parseSingle "{a}" of + case Eff.run . Effs.runError @Error $ parseSingle "{a}" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse an integer literal" $ do let result = LiteralInt 123 - case parseSingle "123" of + case Eff.run . Effs.runError @Error $ parseSingle "123" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse a list literal" $ do let result = SExpression [Symbol "list", LiteralInt 1, LiteralChar 'a'] - case parseSingle "[1 {a}]" of + case Eff.run . Effs.runError @Error $ parseSingle "[1 {a}]" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse a string literal" $ do let result = LiteralString "a b" - case parseSingle "\"a b\"" of + case Eff.run . Effs.runError @Error $ parseSingle "\"a b\"" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse a quasiquoted expression" $ do let result = SExpression [Symbol "quasiquote", SExpression [Symbol "foo", Symbol "bar"]] - case parseSingle "`(foo bar)" of + case Eff.run . Effs.runError @Error $ parseSingle "`(foo bar)" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse an s-expression" $ do let result = SExpression [Symbol "foo", Symbol "bar"] - case parseSingle "(foo bar)" of + case Eff.run . Effs.runError @Error $ parseSingle "(foo bar)" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse a splice-unquoted expression" $ do @@ -48,29 +55,29 @@ [ Symbol "unquoteSplicing" , SExpression [Symbol "foo", Symbol "bar"] ] - case parseSingle "~@(foo bar)" of + case Eff.run . Effs.runError @Error $ parseSingle "~@(foo bar)" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse a symbol" $ do let result = Symbol "abc123'''" - case parseSingle "abc123'''" of + case Eff.run . Effs.runError @Error $ parseSingle "abc123'''" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse an unquoted expression" $ do let result = SExpression [Symbol "unquote", SExpression [Symbol "foo", Symbol "bar"]] - case parseSingle "~(foo bar)" of + case Eff.run . Effs.runError @Error $ parseSingle "~(foo bar)" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can quote a character character" $ do let result = SExpression [Symbol "AST.LiteralChar", LiteralChar 'a'] - case parseSingle "'{a}" of + case Eff.run . Effs.runError @Error $ parseSingle "'{a}" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can quote an integer literal" $ do let result = SExpression [Symbol "AST.LiteralInt", LiteralInt 123] - case parseSingle "'123" of + case Eff.run . Effs.runError @Error $ parseSingle "'123" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can quote a list literal" $ do @@ -84,12 +91,12 @@ , SExpression [Symbol "AST.LiteralInt", LiteralInt 2] ] ] - case parseSingle "'[1 2]" of + case Eff.run . Effs.runError @Error $ parseSingle "'[1 2]" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can quote a string literal" $ do let result = SExpression [Symbol "AST.LiteralString", LiteralString "foo"] - case parseSingle "'\"foo\"" of + case Eff.run . Effs.runError @Error $ parseSingle "'\"foo\"" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can quote an s-expression" $ do @@ -102,12 +109,12 @@ , SExpression [Symbol "AST.LiteralInt", LiteralInt 2] ] ] - case parseSingle "'(1 2)" of + case Eff.run . Effs.runError @Error $ parseSingle "'(1 2)" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can quote a symbol" $ do let result = SExpression [Symbol "AST.Symbol", LiteralString "foo"] - case parseSingle "'foo" of + case Eff.run . Effs.runError @Error $ parseSingle "'foo" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can quote a quoted expression" $ do @@ -120,7 +127,7 @@ , SExpression [Symbol "AST.Symbol", LiteralString "foo"] ] ] - case parseSingle "''foo" of + case Eff.run . Effs.runError @Error $ parseSingle "''foo" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result describe "parseMultiple" $ do @@ -139,7 +146,7 @@ [Symbol "foo", LiteralInt 1, LiteralInt 2, LiteralInt 3] , SExpression [Symbol "bar", Symbol "x", Symbol "y", Symbol "z"] ] - case parseMultiple input of + case Eff.run . Effs.runError @Error $ parseMultiple input of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result describe "parseSource" $ do @@ -155,6 +162,6 @@ , SExpression [Symbol "foo", LiteralInt 1, LiteralInt 2, LiteralInt 3] ] - case parseSource input of + case Eff.run . Effs.runError @Error $ parseSource input of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result