axel 0.0.5 → 0.0.6

raw patch · 47 files changed

+1463/−1463 lines, 47 filesdep +freer-simpledep +singletonsdep −mtldep ~basedep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: freer-simple, singletons

Dependencies removed: mtl

Dependency ranges changed: base, transformers

API changes (from Hackage documentation)

Files

• README.org +3/−0
• app/Main.hs +30/−15
• axel.cabal +18/−20
• resources/autogenerated/macros/AST.hs +4/−3
• scripts/build.sh +1/−1
• src/Axel/AST.hs +29/−0
• src/Axel/Denormalize.hs +22/−7
• src/Axel/Eff/Console.hs +35/−0
• src/Axel/Eff/FileSystem.hs +122/−0
• src/Axel/Eff/Process.hs +95/−0
• src/Axel/Eff/Resource.hs +61/−0
• src/Axel/Error.hs +11/−13
• src/Axel/Haskell/File.hs +31/−28
• src/Axel/Haskell/GHC.hs +0/−50
• src/Axel/Haskell/Project.hs +23/−24
• src/Axel/Haskell/Stack.hs +63/−23
• src/Axel/Macros.hs +84/−112
• src/Axel/Monad/Console.hs +0/−64
• src/Axel/Monad/FileSystem.hs +0/−162
• src/Axel/Monad/Process.hs +0/−81
• src/Axel/Monad/Resource.hs +0/−90
• src/Axel/Normalize.hs +58/−12
• src/Axel/Parse.hs +7/−4
• src/Axel/Parse/AST.hs +4/−3
• src/Axel/Parse/Args.hs +9/−3
• test/Axel/Test/ASTGen.hs +7/−0
• test/Axel/Test/DenormalizeSpec.hs +14/−2
• test/Axel/Test/Eff/ConsoleMock.hs +37/−0
• test/Axel/Test/Eff/ConsoleSpec.hs +20/−0
• test/Axel/Test/Eff/FileSystemMock.hs +266/−0
• test/Axel/Test/Eff/FileSystemSpec.hs +76/−0
• test/Axel/Test/Eff/ProcessMock.hs +108/−0
• test/Axel/Test/Eff/ResourceMock.hs +20/−0
• test/Axel/Test/Eff/ResourceSpec.hs +32/−0
• test/Axel/Test/File/FileSpec.hs +13/−2
• test/Axel/Test/Haskell/GHCSpec.hs +0/−76
• test/Axel/Test/Haskell/StackSpec.hs +114/−33
• test/Axel/Test/MockUtils.hs +12/−4
• test/Axel/Test/Monad/ConsoleMock.hs +0/−46
• test/Axel/Test/Monad/ConsoleSpec.hs +0/−19
• test/Axel/Test/Monad/FileSystemMock.hs +0/−278
• test/Axel/Test/Monad/FileSystemSpec.hs +0/−74
• test/Axel/Test/Monad/ProcessMock.hs +0/−128
• test/Axel/Test/Monad/ResourceMock.hs +0/−40
• test/Axel/Test/Monad/ResourceSpec.hs +0/−27
• test/Axel/Test/NormalizeSpec.hs +9/−1
• test/Axel/Test/ParseSpec.hs +25/−18

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -6,4 +6,4 @@ cp src/Axel/Parse/AST.hs resources/autogenerated/macros/AST.hs echo "Macro header copied!" -stack build+stack build --fast

@@ -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

@@ -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" :

@@ -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")

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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")

@@ -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

@@ -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)

@@ -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"

@@ -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

@@ -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)

@@ -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 

@@ -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")

@@ -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

@@ -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))

@@ -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)

@@ -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)

@@ -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

@@ -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)

@@ -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 _ = "<ProcessResult>"++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"

@@ -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)

@@ -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)

@@ -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))

@@ -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

@@ -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)

@@ -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 <>

@@ -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

@@ -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)

@@ -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 _ = "<FileSystemT>"--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

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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