diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -1,14 +1,20 @@ #+OPTIONS: num:nil toc:nil -#+STARTUP: inlineimages +#+STARTUP: inlineimage * Axel Haskell + Lisp (+ JVM/Node/..., soon) = Profit! See [[https://axellang.github.io]]. #+CAPTION: Build Status [[https://travis-ci.org/axellang/axel.svg?branch=master]] + + *CURRENT STATUS:* I'm currently recovering from some academic burnout (much to my chagrin), hence the dearth of recent activity. I promise that Axel is /not/ abandoned, and active development should resume within the next several months. ** Code Style - Run ~scripts/format.sh~ to format code and ~scripts/lint.sh~ to maintain code quality. + Run ~scripts/format.sh~ to format code and ~scripts/lint.sh~ to run the linter. ** Running - Run ~scripts/build.sh~ to build the project, ~stack run -- ~ to run the project, and ~scripts/test.sh~ to test the project. + Run ~cabal run -- axel ~ to build and run the project. +** Testing + Run ~scripts/test.sh~ to test the project. +*** Golden Tests + To prevent issues like #79: Before committing any new (or modified) golden tests, run `cabal exec ghci -- -package axel` (or equivalent) on the corresponding `hs` files to ensure that they actually parse. (It's okay if they don't compile or evaluate, as long as they are valid Haskell.) ** Examples - See the `.axel` files in this repository for example Axel programs. + See the ~.axel~ files in this repository for example Axel programs. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,30 @@ +-- Adapted from https://github.com/achirkin/easytensor/blob/4cc9a381ad09c7a013a121cc02231f0ac2de649d/dimensions/Setup.hs. +-- This is necessary in case users install Axel through Cabal, and fixes a Haddock bug raised by `polysemy-plugin`. +-- This module disables some errors and warnings during the Haddock pass (caused by compiler plugins and hs-boot). +module Main where + import Distribution.Simple -main = defaultMain +import Distribution.Simple.Setup + +main :: IO () +main = + defaultMainWithHooks + simpleUserHooks {confHook = \a -> confHook simpleUserHooks a . tweakFlags} + +tweakFlags :: ConfigFlags -> ConfigFlags +tweakFlags flags = + flags {configProgramArgs = addHaddockArgs (configProgramArgs flags)} + +addHaddockArgs :: [(String, [String])] -> [(String, [String])] +addHaddockArgs [] = [("haddock", newHaddockGhcArgs)] +addHaddockArgs (("haddock", args):otherProgsArgs) = + ("haddock", args <> newHaddockGhcArgs) : otherProgsArgs +addHaddockArgs (progArgs:otherProgsArgs) = + progArgs : addHaddockArgs otherProgsArgs + +newHaddockGhcArgs :: [String] +newHaddockGhcArgs = + [ "--optghc=-fdefer-type-errors" + , "--optghc=-fno-warn-deferred-type-errors" + , "--optghc=-fno-warn-missing-home-modules" + ] diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,23 +1,24 @@ module Main where import Axel -import qualified Prelude as GHCPrelude -import qualified Axel.Parse.AST as AST +import qualified Prelude as AxelRuntime_GHCPrelude +import qualified Axel.Parse.AST as AxelRuntime_AST +import qualified Axel.Sourcemap as AxelRuntime_Sourcemap import Axel.Eff.App(AppEffs,runApp) import Axel.Eff.Console(putStrLn) -import Axel.Eff.Ghci(withStackGhci) +import Axel.Eff.Ghci(withGhci) +import Axel.Haskell.Cabal(axelVersion) import Axel.Haskell.File(convertFileInPlace,formatFileInPlace,transpileFileInPlace) import Axel.Haskell.Project(buildProject,convertProject,formatProject,runProject) -import Axel.Haskell.Stack(axelStackageVersion) import Axel.Parse.Args(Command(FileCommand,ProjectCommand,Version),FileCommand(ConvertFile,RunFile,FormatFile),ProjectCommand(ConvertProject,FormatProject,RunProject),commandParserInfo) import Control.Monad(void) import qualified Data.Map as Map(empty) +import qualified Effectful as Eff +import qualified Effectful.State.Static.Local as Eff import Options.Applicative(execParser) -import qualified Polysemy as Sem -import qualified Polysemy.State as Sem import Prelude hiding (putStrLn) -app :: () => (((->) Command) (Sem.Sem AppEffs ())) -app (FileCommand fileCommand) = (case fileCommand of {(ConvertFile filePath) -> (void (convertFileInPlace filePath));(FormatFile filePath) -> (formatFileInPlace filePath);(RunFile filePath) -> (void (Sem.evalState Map.empty (withStackGhci (transpileFileInPlace filePath))))}) -app (ProjectCommand projectCommand) = (case projectCommand of {(ConvertProject ) -> convertProject;(FormatProject ) -> formatProject;(RunProject ) -> ((>>) buildProject runProject)}) -app (Version ) = (putStrLn ((<>) "Axel version " axelStackageVersion)) +app :: () => ((->) Command (Eff.Eff AppEffs ())) +app (FileCommand fileCommand) = (case fileCommand of {(ConvertFile filePath) -> (void (convertFileInPlace filePath));(FormatFile filePath) -> (formatFileInPlace filePath);(RunFile filePath) -> (void (Eff.evalState Map.empty (withGhci (transpileFileInPlace filePath))))}) +app (ProjectCommand projectCommand) = (case projectCommand of {ConvertProject -> convertProject;FormatProject -> formatProject;RunProject -> ((>>) buildProject runProject)}) +app Version = (putStrLn ((<>) "Axel version " axelVersion)) main :: () => (IO ()) main = ((>>=) (execParser commandParserInfo) (\modeCommand -> (runApp (app modeCommand)))) diff --git a/axel.cabal b/axel.cabal --- a/axel.cabal +++ b/axel.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack -- --- hash: 99fb260a0ae2149443c78e919a5b97d138da340591cfc306a8345e114b4ae538 +-- hash: 70e8a29914c303051f73ecedc0872e7b4c4c99b19d553f9a4026f59b0e5ec462 name: axel -version: 0.0.12 +version: 0.0.13 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 @@ -15,31 +15,22 @@ bug-reports: https://github.com/axellang/axel/issues author: Joshua Grosso maintainer: jgrosso256@gmail.com -copyright: 2017 Joshua Grosso +copyright: 2020 Joshua Grosso license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: README.org - scripts/clean.sh - scripts/depDocs.sh scripts/format.sh scripts/ghcid.sh scripts/lint.sh scripts/onHsFiles.sh - scripts/repl.sh - scripts/stackProfile.sh scripts/test.sh data-files: - resources/autogenerated/macros/AST.hs resources/new-project-template/app/Main.axel - resources/new-project-template/app/Main.hs resources/new-project-template/Setup.axel - resources/new-project-template/Setup.hs resources/new-project-template/src/Lib.axel - resources/new-project-template/src/Lib.hs resources/new-project-template/test/Spec.axel - resources/new-project-template/test/Spec.hs source-repository head type: git @@ -65,13 +56,13 @@ Axel.Eff.Restartable Axel.Eff.Time Axel.Eff.Unsafe + Axel.Haskell.Cabal Axel.Haskell.Convert Axel.Haskell.Error Axel.Haskell.File Axel.Haskell.Language Axel.Haskell.Macros Axel.Haskell.Project - Axel.Haskell.Stack Axel.Macros Axel.Normalize Axel.Parse @@ -96,52 +87,81 @@ Paths_axel hs-source-dirs: src - default-extensions: BangPatterns ConstraintKinds DataKinds DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds RankNTypes StandaloneDeriving TupleSections TypeApplications TypeOperators - ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-import-lists -Wno-missing-export-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -optP-Wno-nonportable-include-path -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-deriving-strategies -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -Wno-unused-packages -optP-Wno-nonportable-include-path -O2 -fplugin=Effectful.Plugin build-tool-depends: hpack:hpack , tasty-discover:tasty-discover build-depends: - aeson - , ansi-terminal - , base >=4.12 && <4.13 - , bytestring - , containers - , directory - , extra - , filepath - , freer-simple - , ghcid - , hashable - , haskell-src-exts - , hedgehog - , hpack - , lens - , lens-aeson - , megaparsec - , mono-traversable - , optparse-applicative - , polysemy - , polysemy-plugin - , prettyprinter - , process - , profunctors - , random - , split - , tasty - , tasty-discover - , tasty-golden - , tasty-hedgehog - , tasty-hspec - , tasty-hunit - , template-haskell - , text - , time - , transformers - , typed-process - , uniplate - , vector - , yaml + aeson ==2.2.1.0 + , ansi-terminal ==1.0.2 + , base ==4.17.2.1 + , bytestring ==0.11.5.3 + , containers ==0.6.7 + , directory ==1.3.7.1 + , effectful ==2.3.0.0 + , effectful-core ==2.3.0.1 + , effectful-plugin ==1.1.0.2 + , effectful-th ==1.0.0.1 + , extra ==1.7.14 + , filepath ==1.4.2.2 + , ghcid ==0.8.9 + , hashable ==1.4.3.0 + , haskell-src-exts ==1.23.1 + , hedgehog ==1.4 + , hpack ==0.36.0 + , hspec ==2.11.7 + , lens ==5.2.3 + , lens-aeson ==1.2.3 + , megaparsec ==9.6.1 + , mono-traversable ==1.0.15.3 + , optparse-applicative ==0.18.1.0 + , prettyprinter ==1.7.1 + , process ==1.6.18.0 + , profunctors ==5.6.2 + , random ==1.2.1.2 + , split ==0.2.5 + , tasty ==1.5 + , tasty-discover ==5.0.0 + , tasty-golden ==2.3.5 + , tasty-hedgehog ==1.4.0.2 + , tasty-hspec ==1.2.0.4 + , tasty-hunit ==0.10.1 + , template-haskell ==2.19.0.0 + , text ==2.1.1 + , time ==1.12.2 + , transformers ==0.5.6.2 + , typed-process ==0.2.11.1 + , uniplate ==1.6.13 + , vector ==0.13.1.0 + , yaml ==0.11.11.2 default-language: Haskell2010 executable axel @@ -150,53 +170,82 @@ Paths_axel hs-source-dirs: app - default-extensions: BangPatterns ConstraintKinds DataKinds DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds RankNTypes StandaloneDeriving TupleSections TypeApplications TypeOperators - ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-import-lists -Wno-missing-export-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -optP-Wno-nonportable-include-path -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively -threaded -rtsopts -with-rtsopts=-N + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-deriving-strategies -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -Wno-unused-packages -optP-Wno-nonportable-include-path -O2 -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hpack:hpack , tasty-discover:tasty-discover build-depends: - aeson - , ansi-terminal + aeson ==2.2.1.0 + , ansi-terminal ==1.0.2 , axel - , base >=4.12 && <4.13 - , bytestring - , containers - , directory - , extra - , filepath - , freer-simple - , ghcid - , hashable - , haskell-src-exts - , hedgehog - , hpack - , lens - , lens-aeson - , megaparsec - , mono-traversable - , optparse-applicative - , polysemy - , polysemy-plugin - , prettyprinter - , process - , profunctors - , random - , split - , tasty - , tasty-discover - , tasty-golden - , tasty-hedgehog - , tasty-hspec - , tasty-hunit - , template-haskell - , text - , time - , transformers - , typed-process - , uniplate - , vector - , yaml + , base ==4.17.2.1 + , bytestring ==0.11.5.3 + , containers ==0.6.7 + , directory ==1.3.7.1 + , effectful ==2.3.0.0 + , effectful-core ==2.3.0.1 + , effectful-plugin ==1.1.0.2 + , effectful-th ==1.0.0.1 + , extra ==1.7.14 + , filepath ==1.4.2.2 + , ghcid ==0.8.9 + , hashable ==1.4.3.0 + , haskell-src-exts ==1.23.1 + , hedgehog ==1.4 + , hpack ==0.36.0 + , hspec ==2.11.7 + , lens ==5.2.3 + , lens-aeson ==1.2.3 + , megaparsec ==9.6.1 + , mono-traversable ==1.0.15.3 + , optparse-applicative ==0.18.1.0 + , prettyprinter ==1.7.1 + , process ==1.6.18.0 + , profunctors ==5.6.2 + , random ==1.2.1.2 + , split ==0.2.5 + , tasty ==1.5 + , tasty-discover ==5.0.0 + , tasty-golden ==2.3.5 + , tasty-hedgehog ==1.4.0.2 + , tasty-hspec ==1.2.0.4 + , tasty-hunit ==0.10.1 + , template-haskell ==2.19.0.0 + , text ==2.1.1 + , time ==1.12.2 + , transformers ==0.5.6.2 + , typed-process ==0.2.11.1 + , uniplate ==1.6.13 + , vector ==0.13.1.0 + , yaml ==0.11.11.2 default-language: Haskell2010 test-suite axel-test @@ -214,7 +263,8 @@ Axel.Test.Eff.ProcessMock Axel.Test.Eff.ResourceMock Axel.Test.Eff.ResourceSpec - Axel.Test.Haskell.StackSpec + Axel.Test.Haskell.CabalSpec + Axel.Test.Haskell.ErrorSpec Axel.Test.MacrosSpec Axel.Test.NormalizeSpec Axel.Test.Parse.ASTGen @@ -228,51 +278,80 @@ Paths_axel hs-source-dirs: test - default-extensions: BangPatterns ConstraintKinds DataKinds DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds RankNTypes StandaloneDeriving TupleSections TypeApplications TypeOperators - ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-import-lists -Wno-missing-export-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -optP-Wno-nonportable-include-path -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively -threaded -rtsopts -with-rtsopts=-N + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-deriving-strategies -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -Wno-unused-packages -optP-Wno-nonportable-include-path -O2 -fplugin=Effectful.Plugin -threaded -rtsopts -with-rtsopts=-N -Wno-name-shadowing build-tool-depends: hpack:hpack , tasty-discover:tasty-discover build-depends: - aeson - , ansi-terminal + aeson ==2.2.1.0 + , ansi-terminal ==1.0.2 , axel - , base >=4.12 && <4.13 - , bytestring - , containers - , directory - , extra - , filepath - , freer-simple - , ghcid - , hashable - , haskell-src-exts - , hedgehog - , hpack - , lens - , lens-aeson - , megaparsec - , mono-traversable - , optparse-applicative - , polysemy - , polysemy-plugin - , prettyprinter - , process - , profunctors - , random - , split - , tasty - , tasty-discover - , tasty-golden - , tasty-hedgehog - , tasty-hspec - , tasty-hunit - , template-haskell - , text - , time - , transformers - , typed-process - , uniplate - , vector - , yaml + , base ==4.17.2.1 + , bytestring ==0.11.5.3 + , containers ==0.6.7 + , directory ==1.3.7.1 + , effectful ==2.3.0.0 + , effectful-core ==2.3.0.1 + , effectful-plugin ==1.1.0.2 + , effectful-th ==1.0.0.1 + , extra ==1.7.14 + , filepath ==1.4.2.2 + , ghcid ==0.8.9 + , hashable ==1.4.3.0 + , haskell-src-exts ==1.23.1 + , hedgehog ==1.4 + , hpack ==0.36.0 + , hspec ==2.11.7 + , lens ==5.2.3 + , lens-aeson ==1.2.3 + , megaparsec ==9.6.1 + , mono-traversable ==1.0.15.3 + , optparse-applicative ==0.18.1.0 + , prettyprinter ==1.7.1 + , process ==1.6.18.0 + , profunctors ==5.6.2 + , random ==1.2.1.2 + , split ==0.2.5 + , tasty ==1.5 + , tasty-discover ==5.0.0 + , tasty-golden ==2.3.5 + , tasty-hedgehog ==1.4.0.2 + , tasty-hspec ==1.2.0.4 + , tasty-hunit ==0.10.1 + , template-haskell ==2.19.0.0 + , text ==2.1.1 + , time ==1.12.2 + , transformers ==0.5.6.2 + , typed-process ==0.2.11.1 + , uniplate ==1.6.13 + , vector ==0.13.1.0 + , yaml ==0.11.11.2 default-language: Haskell2010 diff --git a/resources/autogenerated/macros/AST.hs b/resources/autogenerated/macros/AST.hs deleted file mode 100644 --- a/resources/autogenerated/macros/AST.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} - --- NOTE Because this file will be used as the header of auto-generated macro programs, --- it can't have any project-specific dependencies (such as `Fix`). -module Axel.Parse.AST where - -import Data.IORef (IORef, modifyIORef, newIORef, readIORef) -import Data.Semigroup ((<>)) - -import System.IO.Unsafe (unsafePerformIO) - -handleStringEscapes :: String -> String -handleStringEscapes = - concatMap $ \case - '\\' -> "\\\\" - c -> [c] - --- ****************************** --- ** AST ** --- ****************************** --- TODO `Expression` should probably be `Traversable`, use recursion schemes, etc. --- We should provide `toFix` and `fromFix` functions for macros to take advantage of. --- (Maybe all macros have the argument automatically `fromFix`-ed to make consumption simpler?) -data Expression ann - = LiteralChar ann Char - | LiteralInt ann Int - | LiteralString ann String - | SExpression ann [Expression ann] - | Symbol ann String - deriving (Eq, Functor, Show) - -bottomUpFmap :: - (Expression ann -> Expression ann) -> Expression ann -> Expression ann -bottomUpFmap f x = - f $ - case x of - LiteralChar _ _ -> x - LiteralInt _ _ -> x - LiteralString _ _ -> x - SExpression ann' xs -> SExpression ann' (map (bottomUpFmap f) xs) - Symbol _ _ -> x - -bottomUpTraverse :: - (Monad m) - => (Expression ann -> m (Expression ann)) - -> Expression ann - -> m (Expression ann) -bottomUpTraverse f x = - f =<< - case x of - LiteralChar _ _ -> pure x - LiteralInt _ _ -> pure x - LiteralString _ _ -> pure x - SExpression ann' xs -> SExpression ann' <$> traverse (bottomUpTraverse f) xs - Symbol _ _ -> pure x - -topDownFmap :: - (Expression ann -> Expression ann) -> Expression ann -> Expression ann -topDownFmap f x = - case f x of - LiteralChar _ _ -> x - LiteralInt _ _ -> x - LiteralString _ _ -> x - SExpression ann' xs -> SExpression ann' (map (topDownFmap f) xs) - Symbol _ _ -> x - --- ****************************** --- ** Sourcemap ** --- ****************************** -data SourcePosition = - SourcePosition - { line :: Int - , column :: Int - } - deriving (Eq, Show) - -renderSourcePosition :: SourcePosition -> String -renderSourcePosition sourcePosition = - show (line sourcePosition) <> ":" <> show (column sourcePosition) - -data SourceMetadata - = Nothing - | FromSource SourcePosition - deriving (Eq, Show) - --- ****************************** --- ** Internal ** --- ****************************** -toAxel :: Expression ann -> String -toAxel (LiteralChar _ x) = ['{', x, '}'] -toAxel (LiteralInt _ x) = show x -toAxel (LiteralString _ xs) = "\"" <> xs <> "\"" -toAxel (SExpression _ (Symbol _ "applyInfix":xs)) = - "{" <> unwords (map toAxel xs) <> "}" -toAxel (SExpression _ (Symbol _ "list":xs)) = - "[" <> unwords (map toAxel xs) <> "]" -toAxel (SExpression _ [Symbol _ "quote", x]) = '\'' : toAxel x -toAxel (SExpression _ [Symbol _ "quasiquote", x]) = '`' : toAxel x -toAxel (SExpression _ [Symbol _ "unquote", x]) = '~' : toAxel x -toAxel (SExpression _ [Symbol _ "unquoteSplicing", x]) = "~@" <> toAxel x -toAxel (SExpression _ xs) = "(" <> unwords (map toAxel xs) <> ")" -toAxel (Symbol _ x) = x - --- ****************************** --- ** Quoting ** --- ****************************** --- TODO Derive these with Template Haskell (they're currently very brittle) -quoteSourceMetadata :: SourceMetadata -> Expression SourceMetadata -quoteSourceMetadata sm@Nothing = Symbol sm "AST.Nothing" -quoteSourceMetadata sm@(FromSource sourcePosition) = - SExpression - sm - [ Symbol sm "AST.FromSource" - , SExpression - sm - [ Symbol sm "AST.SourcePosition" - , LiteralInt sm (line sourcePosition) - , LiteralInt sm (column sourcePosition) - ] - ] - -quoteParseExpression :: Expression SourceMetadata -> Expression SourceMetadata -quoteParseExpression (LiteralChar ann' x) = - SExpression - ann' - [ Symbol ann' "AST.LiteralChar" - , quoteSourceMetadata ann' - , LiteralChar ann' x - ] -quoteParseExpression (LiteralInt ann' x) = - SExpression - ann' - [Symbol ann' "AST.LiteralInt", quoteSourceMetadata ann', LiteralInt ann' x] -quoteParseExpression (LiteralString ann' x) = - SExpression - ann' - [ Symbol ann' "AST.LiteralString" - , quoteSourceMetadata ann' - , LiteralString ann' x - ] -quoteParseExpression (SExpression ann' xs) = - SExpression - ann' - [ Symbol ann' "AST.SExpression" - , quoteSourceMetadata ann' - , SExpression ann' (Symbol ann' "list" : map quoteParseExpression xs) - ] -quoteParseExpression (Symbol ann' x) = - SExpression - ann' - [ Symbol ann' "AST.Symbol" - , quoteSourceMetadata ann' - , LiteralString ann' (handleStringEscapes x) - ] - --- ****************************** --- ** Macro definition ** --- ****************************** -{-# NOINLINE gensymCounter #-} -gensymCounter :: IORef Int -gensymCounter = unsafePerformIO $ newIORef 0 - -gensym :: IO (Expression SourceMetadata) -gensym = do - suffix <- readIORef gensymCounter - let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" <> show suffix - modifyIORef gensymCounter succ - pure $ Symbol Nothing identifier - --- | This allows splice-unquoting of both `[Expression]`s and `SExpression`s, --- without requiring special syntax for each. -class ToExpressionList a where - type Annotation a - toExpressionList :: a -> [Expression (Annotation a)] - -instance ToExpressionList [Expression ann] where - type Annotation [Expression ann] = ann - toExpressionList :: [Expression ann] -> [Expression ann] - toExpressionList = id - --- | Because we do not have a way to statically ensure an `SExpression` is passed --- (and not another one of `Expression`'s constructors instead), --- we will error at compile-time if a macro attempts to splice-unquote inappropriately. -instance ToExpressionList (Expression ann) where - type Annotation (Expression ann) = ann - toExpressionList :: Expression ann -> [Expression ann] - toExpressionList (SExpression _ xs) = xs - toExpressionList x = - error - (toAxel x <> - " cannot be splice-unquoted, because it is not an s-expression!") - -wrapCompoundExpressions :: - [Expression SourceMetadata] -> Expression SourceMetadata -wrapCompoundExpressions stmts = - SExpression Nothing (Symbol Nothing "begin" : stmts) - -unwrapCompoundExpressions :: Expression ann -> [Expression ann] -unwrapCompoundExpressions (SExpression _ (Symbol _ "begin":stmts)) = stmts -unwrapCompoundExpressions _ = - error "unwrapCompoundExpressions must be passed a top-level program!" diff --git a/resources/new-project-template/Setup.hs b/resources/new-project-template/Setup.hs deleted file mode 100644 --- a/resources/new-project-template/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple ( defaultMain ) -main IO () = (() defaultMain) - where diff --git a/resources/new-project-template/app/Main.hs b/resources/new-project-template/app/Main.hs deleted file mode 100644 --- a/resources/new-project-template/app/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where -import Lib -main IO () = (() someFunc) - where diff --git a/resources/new-project-template/src/Lib.hs b/resources/new-project-template/src/Lib.hs deleted file mode 100644 --- a/resources/new-project-template/src/Lib.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Lib where -someFunc IO () = (() (putStrLn "someFunc")) - where diff --git a/resources/new-project-template/test/Spec.hs b/resources/new-project-template/test/Spec.hs deleted file mode 100644 --- a/resources/new-project-template/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main IO () = (() (putStrLn "Test suite not yet implemented")) - where diff --git a/scripts/clean.sh b/scripts/clean.sh deleted file mode 100644 --- a/scripts/clean.sh +++ /dev/null @@ -1,8 +0,0 @@ -set -eu -set -o pipefail - -echo "Cleaning autogenerated resources..." -rm -rf resources/autogenerated -echo "Autogenerated resources cleaned!" - -stack clean diff --git a/scripts/depDocs.sh b/scripts/depDocs.sh deleted file mode 100644 --- a/scripts/depDocs.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh - -stack haddock --open --only-dependencies diff --git a/scripts/ghcid.sh b/scripts/ghcid.sh --- a/scripts/ghcid.sh +++ b/scripts/ghcid.sh @@ -1,1 +1,1 @@ -ghcid --command "stack repl axel:lib axel:test:axel-test --ghci-options=-fno-code" +ghcid --command "cabal repl -fno-code" diff --git a/scripts/lint.sh b/scripts/lint.sh --- a/scripts/lint.sh +++ b/scripts/lint.sh @@ -1,1 +1,1 @@ -./scripts/onHsFiles.sh hlint --color=always | grep -v 'No hints' +./scripts/onHsFiles.sh hlint --color=always --cross -j diff --git a/scripts/onHsFiles.sh b/scripts/onHsFiles.sh --- a/scripts/onHsFiles.sh +++ b/scripts/onHsFiles.sh @@ -1,1 +1,1 @@ -find app src test -type f | grep '^.*\.hs$' | grep -v 'app/Main.hs' | grep -v 'src/Axel/Parse/Args.hs' | grep -v 'src/Axel.hs' | grep -v 'src/Axel/Haskell/Macros.hs' | xargs -L 1 $@ +find app src test -iname "*.hs" ! -path "app/Main.hs" ! -path "src/Axel/Parse/Args.hs" ! -path "src/Axel.hs" ! -path "src/Axel/Haskell/Macros.hs" ! -name "golden_*.hs" -print0 | xargs -0 "$@" diff --git a/scripts/repl.sh b/scripts/repl.sh deleted file mode 100644 --- a/scripts/repl.sh +++ /dev/null @@ -1,1 +0,0 @@ -stack repl axel:lib axel:test:axel-test diff --git a/scripts/stackProfile.sh b/scripts/stackProfile.sh deleted file mode 100644 --- a/scripts/stackProfile.sh +++ /dev/null @@ -1,1 +0,0 @@ -stack --work-dir .stack-work-profile --profile "$@" diff --git a/scripts/test.sh b/scripts/test.sh --- a/scripts/test.sh +++ b/scripts/test.sh @@ -3,6 +3,7 @@ # Sometimes, when macro expansion tests are run, `ghc` will stay alive # and consume ridiculous amounts of memory and CPU. +# TODO Only kill `ghc`s spawned by this process. trap "killall axel-test ghc" EXIT -stack test --fast --ghc-options "-g" --test-arguments "--hide-successes" "$@" +cabal test --test-options="--hide-successes --num-threads=1" --test-show-details=direct "$@" diff --git a/src/Axel.hs b/src/Axel.hs --- a/src/Axel.hs +++ b/src/Axel.hs @@ -1,9 +1,11 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Axel where -import qualified Prelude as GHCPrelude -import qualified Axel.Parse.AST as AST +import qualified Prelude as AxelRuntime_GHCPrelude +import qualified Axel.Parse.AST as AxelRuntime_AST +import qualified Axel.Sourcemap as AxelRuntime_Sourcemap import Axel.Prelude import Axel.Parse(hygenisizeIdentifier) +import qualified Axel.Parse.AST as AST import qualified Axel.Sourcemap as SM import Axel.Utils.FilePath(takeFileName) import Data.IORef(IORef,modifyIORef,newIORef,readIORef) @@ -13,9 +15,9 @@ aXEL_SYMBOL_IF_ True x _ = x aXEL_SYMBOL_IF_ False _ x = x expandDo :: () => ((->) ([] SM.Expression) SM.Expression) -expandDo ((:) (AST.SExpression _ [(AST.Symbol _ "<-"),var,val]) rest) = (AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 45 8))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/4333779294880851293/result.axel" (SM.Position 2 156))) ">>=")],[val],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 45 18))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/4333779294880851293/result.axel" (SM.Position 2 254))) "\\")],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 45 21))) (concat [[var]]))],[(expandDo rest)]]))]])) -expandDo ((:) (AST.SExpression _ ((:) (AST.Symbol _ "aXEL_SYMBOL_LET_") bindings)) rest) = (AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 47 8))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/4333779294880851293/result.axel" (SM.Position 3 173))) "aXEL_SYMBOL_LET_")],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 47 13))) (concat [(AST.toExpressionList bindings)]))],[(expandDo rest)]])) -expandDo ((:) val rest) = (case rest of {[] -> val;_ -> (AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 51 13))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/4333779294880851293/result.axel" (SM.Position 4 137))) ">>")],[val],[(expandDo rest)]]))}) +expandDo ((:) (AST.SExpression _ [(AxelRuntime_AST.Symbol _ "<-"),var,val]) rest) = (AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 44 8))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "axelTemp/3735029020733611241/result.axel" (AxelRuntime_Sourcemap.Position 2 199))) ">>=")],[val],[(AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 44 18))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "axelTemp/3735029020733611241/result.axel" (AxelRuntime_Sourcemap.Position 2 340))) "\\")],[(AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 44 21))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "axelTemp/3735029020733611241/result.axel" (AxelRuntime_Sourcemap.Position 2 473))) "list")],[var]]))],[(expandDo rest)]]))]])) +expandDo ((:) (AST.SExpression _ ((:) (AxelRuntime_AST.Symbol _ "aXEL_SYMBOL_LET_") bindings)) rest) = (AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 46 8))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "axelTemp/3735029020733611241/result.axel" (AxelRuntime_Sourcemap.Position 3 216))) "aXEL_SYMBOL_LET_")],[(AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 46 13))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "axelTemp/3735029020733611241/result.axel" (AxelRuntime_Sourcemap.Position 3 364))) "list")],(AxelRuntime_AST.toExpressionList bindings)]))],[(expandDo rest)]])) +expandDo ((:) val rest) = (case rest of {[] -> val;_ -> (AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 48 31))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "axelTemp/3735029020733611241/result.axel" (AxelRuntime_Sourcemap.Position 4 180))) ">>")],[val],[(expandDo rest)]]))}) gensymCounter :: () => (IORef Int) gensymCounter = (unsafePerformIO (newIORef 0)) {-# NOINLINE gensymCounter #-} @@ -24,16 +26,19 @@ isPrelude :: () => ((->) FilePath Bool) isPrelude = ((.) ((==) (FilePath "Axel.axel")) takeFileName) preludeMacros :: () => ([] Text) -preludeMacros = (map ((.) T.pack hygenisizeIdentifier) ["applyInfix","defmacro","def","do","\\case","syntaxQuote"]) -applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION [x,op,y] = (pure [(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 17 17))) (concat [[op],[x],[y]]))]) -defmacro_AXEL_AUTOGENERATED_MACRO_DEFINITION ((:) name cases) = (pure (map (\(AST.SExpression _ ((:) args body)) -> (AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 22 55))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 22 56))) "aXEL_VALUE_aXEL_SYMBOL_EQUALS_macro")],[name],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 22 69))) (concat [[args]]))],(AST.toExpressionList body)]))) cases)) -def_AXEL_AUTOGENERATED_MACRO_DEFINITION ((:) name ((:) typeSig cases)) = (pure ((:) (AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 28 17))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/6581439545403261561/result.axel" (SM.Position 1 166))) "::")],[name],(AST.toExpressionList typeSig)])) (map (\(AST.SExpression _ ((:) args xs)) -> (AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 29 59))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/6581439545403261561/result.axel" (SM.Position 1 339))) "=")],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 29 62))) (concat [[name],(AST.toExpressionList args)]))],(AST.toExpressionList xs)]))) cases))) +preludeMacros = (map ((.) T.pack hygenisizeIdentifier) ["|","applyInfix","defmacro","def","do","\\case","syntaxQuote"]) +applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION [op,x] = (pure [(AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 14 35))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 14 36))) "flip")],[op],[x]]))]) +applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION [x,op,y] = (pure [(AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 16 37))) (concat [[op],[x],[y]]))]) +defmacro_AXEL_AUTOGENERATED_MACRO_DEFINITION ((:) name cases) = (pure (map (\(AST.SExpression _ ((:) args body)) -> (AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 20 24))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 20 25))) "aXEL_VALUE_aXEL_SYMBOL_EQUALS_macro")],[name],[args],(AxelRuntime_AST.toExpressionList body)]))) cases)) +def_AXEL_AUTOGENERATED_MACRO_DEFINITION ((:) name ((:) typeSig cases)) = (pure ((:) (AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 26 15))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "axelTemp/2511363082445148512/result.axel" (AxelRuntime_Sourcemap.Position 1 207))) "::")],[name],(AxelRuntime_AST.toExpressionList typeSig)])) (map (\(AST.SExpression _ ((:) (AST.SExpression _ ((:) (AST.Symbol _ "list") args)) xs)) -> (AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 32 17))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "axelTemp/2511363082445148512/result.axel" (AxelRuntime_Sourcemap.Position 1 481))) "=")],[(AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 32 20))) (concat [[name],(AxelRuntime_AST.toExpressionList args)]))],(AxelRuntime_AST.toExpressionList xs)]))) cases))) syntaxQuote_AXEL_AUTOGENERATED_MACRO_DEFINITION [x] = (pure [(AST.quoteExpression (const (AST.Symbol Nothing "_")) x)]) aXEL_SYMBOL_DO__AXEL_AUTOGENERATED_MACRO_DEFINITION input = (pure [(expandDo input)]) -aXEL_VALUE_aXEL_SYMBOL_BACKSLASH_case_AXEL_AUTOGENERATED_MACRO_DEFINITION cases = (fmap (\varId -> [(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 70 15))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/1949692869127002033/result.axel" (SM.Position 1 188))) "\\")],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 70 18))) (concat [[varId]]))],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 70 27))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/1949692869127002033/result.axel" (SM.Position 1 375))) "case")],[varId],(AST.toExpressionList cases)]))]]))]) gensym) -applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> GHCPrelude.IO [AST.Expression SM.SourceMetadata] -defmacro_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> GHCPrelude.IO [AST.Expression SM.SourceMetadata] -def_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> GHCPrelude.IO [AST.Expression SM.SourceMetadata] -syntaxQuote_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> GHCPrelude.IO [AST.Expression SM.SourceMetadata] -aXEL_SYMBOL_DO__AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> GHCPrelude.IO [AST.Expression SM.SourceMetadata] -aXEL_VALUE_aXEL_SYMBOL_BACKSLASH_case_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> GHCPrelude.IO [AST.Expression SM.SourceMetadata] +aXEL_VALUE_aXEL_SYMBOL_BACKSLASH_case_AXEL_AUTOGENERATED_MACRO_DEFINITION cases = (fmap (\varId -> [(AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 68 28))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 68 29))) "\\")],[(AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 68 31))) (concat [[(AxelRuntime_AST.Symbol AxelRuntime_GHCPrelude.Nothing "list")],[varId]]))],[(AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 68 40))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 68 41))) "case")],[varId],(AxelRuntime_AST.toExpressionList cases)]))]]))]) gensym) +(|%%%%%%%%%%) cases = (pure [(foldr (\(AST.SExpression _ [cond,x]) acc -> (AxelRuntime_AST.SExpression (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 74 51))) (concat [[(AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 74 52))) "aXEL_SYMBOL_IF_")],[cond],[x],[acc]]))) (AxelRuntime_AST.Symbol (AxelRuntime_GHCPrelude.Just ((,) "src/Axel.axel" (AxelRuntime_Sourcemap.Position 75 13))) "undefined") cases)]) +applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] -> AxelRuntime_GHCPrelude.IO [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] +defmacro_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] -> AxelRuntime_GHCPrelude.IO [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] +def_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] -> AxelRuntime_GHCPrelude.IO [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] +syntaxQuote_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] -> AxelRuntime_GHCPrelude.IO [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] +aXEL_SYMBOL_DO__AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] -> AxelRuntime_GHCPrelude.IO [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] +aXEL_VALUE_aXEL_SYMBOL_BACKSLASH_case_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] -> AxelRuntime_GHCPrelude.IO [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] +(|%%%%%%%%%%) :: [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] -> AxelRuntime_GHCPrelude.IO [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] diff --git a/src/Axel/AST.hs b/src/Axel/AST.hs --- a/src/Axel/AST.hs +++ b/src/Axel/AST.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} @@ -11,8 +10,7 @@ import Axel.Haskell.Macros (hygenisizeMacroName) import qualified Axel.Parse.AST as Parse import Axel.Sourcemap - ( Bracket(CurlyBraces, DoubleQuotes, Parentheses, SingleQuotes, - SquareBrackets) + ( Bracket(CurlyBraces, Parentheses, SquareBrackets) , Delimiter(Commas, Newlines, Pipes, Spaces) ) import qualified Axel.Sourcemap as SM @@ -24,7 +22,6 @@ , surround ) import qualified Axel.Utils.Display as Display (delimit, renderPragma, surround) -import Axel.Utils.Text (handleCharEscapes) import Axel.Utils.Tuple (annotate, unannotated) import Control.Lens.Combinators (_head, _last) @@ -34,7 +31,6 @@ import Control.Monad ((>=>)) import Data.Data (Data) -import Data.Semigroup ((<>)) import qualified Data.Text as T class ToHaskell a where @@ -45,75 +41,105 @@ data CaseBlock ann = CaseBlock { _ann :: ann - , _expr :: Expression ann - , _matches :: [(Expression ann, Expression ann)] + , _expr :: Expression ann -- ^ The expression being matched on. + , _matches :: [(Expression ann, Expression ann)] -- ^ The (pattern, value) clauses. } deriving (Data, Eq, Functor, Show) data FunctionApplication ann = FunctionApplication { _ann :: ann - , _function :: Expression ann - , _arguments :: [Expression ann] + , _function :: Expression ann -- ^ The function being applied. + , _arguments :: [Expression ann] -- ^ The arguments to the function. } deriving (Data, Eq, Functor, Show) +-- | This is so that macros can return multiple statements at the top-level without +-- pervasive use of `begin`- or `progn`-esque special forms. Because entire programs +-- are wrapped in this special form, individual macros are able to return multiple +-- forms directly (i.e. returning them as an array). +-- +-- This should not be created, manipulated, etc. in Axel programs. It's generated and +-- manipulated internally, and using it directly in Axel programs should be considered +-- undefined behavior. data TopLevel ann = TopLevel { _ann :: ann - , _statements :: [Statement ann] + , _statements :: [Statement ann] -- ^ The top-level statements in the program. } deriving (Data, Eq, Functor, Show) +-- TODO Name this more clearly. +-- TODO Do `ProperType` and `TypeConstructor` need to be separate cases, since they only +-- differ in arity? +-- | The left-hand side of e.g. a @data@ clause (that is, @data = ...@). data TypeDefinition ann - = ProperType ann Identifier - | TypeConstructor ann (FunctionApplication ann) + = ProperType ann Identifier -- ^ A type that has no arguments, e.g. @Foo@. + | TypeConstructor ann (FunctionApplication ann) -- ^ A type with arguments, e.g. @Foo a@. deriving (Data, Eq, Functor, Show) +-- | An ADT definition. data DataDeclaration ann = DataDeclaration { _ann :: ann - , _typeDefinition :: TypeDefinition ann - , _constructors :: [Expression ann] + , _typeDefinition :: TypeDefinition ann -- ^ The type being defined. + , _constructors :: [Expression ann] -- ^ The data constructors. + , _derivedConstraints :: [Expression ann] -- ^ The constraints to derive, e.g. @Eq@ and @Show@ in @data Foo = Foo deriving (Eq, Show)@. } deriving (Data, Eq, Functor, Show) +-- | A newtype definition. data NewtypeDeclaration ann = NewtypeDeclaration { _ann :: ann - , _typeDefinition :: TypeDefinition ann - , _wrappedType :: Expression ann + , _typeDefinition :: TypeDefinition ann -- ^ The newtype being defined. + , _wrappedType :: Expression ann -- ^ The old type being wrapped (for example, @Bar@ in @newtype Foo = Foo Bar@). + , _derivedConstraints :: [Expression ann] -- ^ The constraints to derive, e.g. @Eq@ and @Show@ in @newtype Foo = Foo Bar deriving (Eq, Show)@. } deriving (Data, Eq, Functor, Show) +-- | A value-level definition. data FunctionDefinition ann = FunctionDefinition { _ann :: ann - , _name :: Identifier - , _arguments :: [Expression ann] - , _body :: Expression ann - , _whereBindings :: [Statement ann] + , _name :: Identifier -- ^ The name of the function being defined. + , _arguments :: [Expression ann] -- ^ The argument list of the function being defined. + , _body :: Expression ann -- ^ The value the function is defined to compute. + , _whereBindings :: [Statement ann] -- ^ The function's @where@-bindings. } deriving (Data, Eq, Functor, Show) +-- | An element of an import list. data Import ann - = ImportItem ann Identifier - | ImportType ann Identifier [Identifier] + = ImportItem ann Identifier -- ^ An identifier to import. + | ImportType ann Identifier [Identifier] -- ^ A type with sub-definitions, e.g @Foo(Bar, Baz)@. deriving (Data, Eq, Functor, Show) +-- | Specifies what to import from a module. data ImportSpecification ann - = ImportAll ann - | ImportOnly ann [Import ann] + = ImportAll ann -- ^ Import everything from the module. + | ImportOnly ann [Import ann] -- ^ Import only specific items from the module. deriving (Data, Eq, Functor, Show) +-- | A lambda expression. data Lambda ann = Lambda { _ann :: ann - , _arguments :: [Expression ann] - , _body :: Expression ann + , _arguments :: [Expression ann] -- ^ The arguments to the lambda. + , _body :: Expression ann -- ^ The value computed by the lambda. } deriving (Data, Eq, Functor, Show) +-- | An as-pattern (e.g. @foo\@bar@). +data PatternBinding ann = + PatternBinding + { _ann :: ann + , _name :: Expression ann -- ^ The name to bind the pattern to, e.g. @foo@ in @foo\@bar@. + , _pattern' :: Expression ann -- ^ The pattern to be bound to the name, e.g. @bar@ in @foo\@bar@. + } + deriving (Data, Eq, Functor, Show) + +-- | A @let@-block. data LetBlock ann = LetBlock { _ann :: ann @@ -225,6 +251,7 @@ | ELambda (Lambda ann) | ELetBlock (LetBlock ann) | ELiteral (Literal ann) + | EPatternBinding (PatternBinding ann) | ERawExpression ann Text | ERecordDefinition (RecordDefinition ann) | ERecordType (RecordType ann) @@ -278,6 +305,8 @@ makeFieldsNoPrefix ''QualifiedImport +makeFieldsNoPrefix ''PatternBinding + makeFieldsNoPrefix ''RecordDefinition makeFieldsNoPrefix ''RecordType @@ -316,6 +345,7 @@ getAnn (ELambda lambda) = lambda ^. ann getAnn (ELetBlock letBlock) = letBlock ^. ann getAnn (ELiteral literal) = getAnn literal + getAnn (EPatternBinding patternBinding) = patternBinding ^. ann getAnn (ERawExpression ann' _) = ann' getAnn (ERecordDefinition recordDefinition) = recordDefinition ^. ann getAnn (ERecordType recordType) = recordType ^. ann @@ -420,13 +450,10 @@ instance ToHaskell (Literal (Maybe SM.Expression)) where toHaskell :: Literal (Maybe SM.Expression) -> SM.Output - toHaskell literal@(LChar _ x) = - mkHaskell literal $ - Display.surround SingleQuotes (handleCharEscapes (T.singleton x)) + toHaskell literal@(LChar _ x) = mkHaskell literal $ showText x toHaskell literal@(LFloat _ x) = mkHaskell literal $ showText x toHaskell literal@(LInt _ x) = mkHaskell literal $ showText x - toHaskell literal@(LString _ x) = - mkHaskell literal $ Display.surround DoubleQuotes (handleCharEscapes x) + toHaskell literal@(LString _ x) = mkHaskell literal $ showText x instance ToHaskell (TypeSignature (Maybe SM.Expression)) where toHaskell :: TypeSignature (Maybe SM.Expression) -> SM.Output @@ -462,19 +489,20 @@ SM.delimit Pipes (map (tryRemoveSurroundingParentheses . toHaskell) $ dataDeclaration ^. - constructors) + constructors) <> + mkHaskell dataDeclaration " deriving " <> + SM.surround + Parentheses + (SM.delimit Commas $ map toHaskell $ dataDeclaration ^. derivedConstraints) where + tryRemoveSurroundingParentheses :: SM.Output -> SM.Output tryRemoveSurroundingParentheses xs = if "(" `T.isPrefixOf` (xs ^. _Wrapped . _head . unannotated) - then removeSurroundingParentheses xs + then let removeOpen = _Wrapped . _head . unannotated %~ T.tail + removeClosed = _Wrapped . _last . unannotated %~ T.init + in removeOpen $ removeClosed xs else xs -removeSurroundingParentheses :: SM.Output -> SM.Output -removeSurroundingParentheses = removeOpen . removeClosed - where - removeOpen = _Wrapped . _head . unannotated %~ T.tail - removeClosed = _Wrapped . _last . unannotated %~ T.init - instance ToHaskell (NewtypeDeclaration (Maybe SM.Expression)) where toHaskell :: NewtypeDeclaration (Maybe SM.Expression) -> SM.Output toHaskell newtypeDeclaration = @@ -482,7 +510,13 @@ toHaskell (newtypeDeclaration ^. typeDefinition) <> mkHaskell newtypeDeclaration " = " <> constructor <> - toHaskell (newtypeDeclaration ^. wrappedType) + mkHaskell newtypeDeclaration " " <> + toHaskell (newtypeDeclaration ^. wrappedType) <> + mkHaskell newtypeDeclaration " deriving " <> + SM.surround + Parentheses + (SM.delimit Commas $ map toHaskell $ newtypeDeclaration ^. + derivedConstraints) where constructor = case newtypeDeclaration ^. typeDefinition of @@ -502,6 +536,13 @@ toHaskell pragma = mkHaskell pragma $ Display.renderPragma (pragma ^. pragmaSpecification) +instance ToHaskell (PatternBinding (Maybe SM.Expression)) where + toHaskell :: PatternBinding (Maybe SM.Expression) -> SM.Output + toHaskell patternBinding = + SM.surround Parentheses $ toHaskell (patternBinding ^. name) <> + mkHaskell patternBinding "@" <> + toHaskell (patternBinding ^. pattern') + instance ToHaskell (LetBlock (Maybe SM.Expression)) where toHaskell :: LetBlock (Maybe SM.Expression) -> SM.Output toHaskell letBlock = @@ -510,8 +551,8 @@ mkHaskell letBlock " in " <> toHaskell (letBlock ^. body) where - bindingToHaskell (pattern', value) = - toHaskell pattern' <> mkHaskell letBlock " = " <> toHaskell value + bindingToHaskell (pat, val) = + toHaskell pat <> mkHaskell letBlock " = " <> toHaskell val instance ToHaskell (MacroDefinition (Maybe SM.Expression)) where toHaskell :: MacroDefinition (Maybe SM.Expression) -> SM.Output @@ -558,6 +599,7 @@ toHaskell (ELambda x) = toHaskell x toHaskell (ELetBlock x) = toHaskell x toHaskell (ELiteral x) = toHaskell x + toHaskell (EPatternBinding x) = toHaskell x toHaskell expr'@(ERawExpression _ x) = mkHaskell expr' x toHaskell (ERecordDefinition x) = toHaskell x toHaskell (ERecordType x) = toHaskell x diff --git a/src/Axel/Denormalize.hs b/src/Axel/Denormalize.hs --- a/src/Axel/Denormalize.hs +++ b/src/Axel/Denormalize.hs @@ -4,8 +4,8 @@ import Axel.AST ( Expression(ECaseBlock, EEmptySExpression, EFunctionApplication, - EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression, - ERecordDefinition, ERecordType) + EIdentifier, ELambda, ELetBlock, ELiteral, EPatternBinding, + ERawExpression, ERecordDefinition, ERecordType) , Import(ImportItem, ImportType) , ImportSpecification(ImportAll, ImportOnly) , Literal(LChar, LFloat, LInt, LString) @@ -26,6 +26,7 @@ , constructors , definition , definitions + , derivedConstraints , expr , fields , function @@ -36,6 +37,7 @@ , matches , moduleName , name + , pattern' , pragmaSpecification , signatures , typeDefinition @@ -44,12 +46,13 @@ ) import qualified Axel.Parse.AST as Parse import qualified Axel.Sourcemap as SM +import Axel.Utils.List (unsafeHead) -import Control.Lens.Operators ((^.)) +import Control.Lens.Operators ((^.), (|>)) import qualified Data.Text as T --- | Metadata is only approximately restored. Thus, `normalizeExpression` and +-- | Metadata is only approximately restored. Thus, `Axel.Normalize.normalizeExpression` and -- | `denormalizeExpression` are only inverses if metadata information is -- | ignored, although they should be pretty close either way. denormalizeExpression :: SMExpression -> SM.Expression @@ -76,7 +79,8 @@ denormalizeExpression (ELambda lambda) = let ann' = getAnn' lambda denormalizedArguments = - Parse.SExpression ann' $ map denormalizeExpression (lambda ^. arguments) + Parse.SExpression ann' $ Parse.Symbol ann' "list" : + map denormalizeExpression (lambda ^. arguments) in Parse.SExpression ann' [ Parse.Symbol ann' "\\" @@ -86,7 +90,7 @@ denormalizeExpression (ELetBlock letBlock) = let ann' = getAnn' letBlock denormalizedBindings = - Parse.SExpression ann' $ + Parse.SExpression ann' $ Parse.Symbol ann' "list" : map (\(var, val) -> Parse.SExpression @@ -105,6 +109,14 @@ LFloat _ float -> Parse.LiteralFloat (getAnn' x) float LInt _ int -> Parse.LiteralInt (getAnn' x) int LString _ string -> Parse.LiteralString (getAnn' x) (T.unpack string) +denormalizeExpression (EPatternBinding patternBinding) = + let ann' = getAnn' patternBinding + in Parse.SExpression + ann' + [ Parse.Symbol ann' "@" + , denormalizeExpression (patternBinding ^. name) + , denormalizeExpression (patternBinding ^. pattern') + ] denormalizeExpression expr'@(ERawExpression _ rawSource) = let ann' = getAnn' expr' in Parse.SExpression @@ -138,7 +150,9 @@ denormalizeImportSpecification importSpec@(ImportAll _) = Parse.Symbol (getAnn' importSpec) "all" denormalizeImportSpecification importSpec@(ImportOnly _ importList) = - Parse.SExpression (getAnn' importSpec) $ map denormalizeImport importList + let ann' = getAnn' importSpec + in Parse.SExpression ann' $ Parse.Symbol ann' "list" : + map denormalizeImport importList where denormalizeImport importList'@(ImportItem _ item) = Parse.Symbol (getAnn' importList') (T.unpack item) @@ -160,10 +174,14 @@ Parse.Symbol (getAnn' $ dataDeclaration ^. typeDefinition) (T.unpack properType) - in Parse.SExpression - ann' - (Parse.Symbol ann' "data" : denormalizedTypeDefinition : - map denormalizeExpression (dataDeclaration ^. constructors)) + denormalizedConstructors = + map denormalizeExpression (dataDeclaration ^. constructors) + denormalizedDerivedConstraintList = + Parse.SExpression ann' $ Parse.Symbol ann' "list" : + map denormalizeExpression (dataDeclaration ^. derivedConstraints) + in Parse.SExpression ann' $ Parse.Symbol ann' "data" : + denormalizedTypeDefinition : + (denormalizedConstructors |> denormalizedDerivedConstraintList) denormalizeStatement (SFunctionDefinition fnDef) = let ann' = getAnn' fnDef in Parse.SExpression ann' $ Parse.Symbol ann' "=" : @@ -177,9 +195,8 @@ let ann' = getAnn' macroDef in Parse.SExpression ann' $ Parse.Symbol ann' "=macro" : Parse.Symbol ann' (T.unpack $ macroDef ^. functionDefinition . name) : - Parse.SExpression - ann' - (map denormalizeExpression (macroDef ^. functionDefinition . arguments)) : + denormalizeExpression + (unsafeHead $ macroDef ^. functionDefinition . arguments) : denormalizeExpression (macroDef ^. functionDefinition . body) : map denormalizeStatement (macroDef ^. functionDefinition . whereBindings) denormalizeStatement (SMacroImport macroImport) = @@ -188,7 +205,7 @@ ann' [ Parse.Symbol ann' "importm" , Parse.Symbol ann' (T.unpack $ macroImport ^. moduleName) - , Parse.SExpression ann' $ + , Parse.SExpression ann' $ Parse.Symbol ann' "list" : map (Parse.Symbol ann' . T.unpack) (macroImport ^. imports) ] denormalizeStatement stmt@(SModuleDeclaration _ identifier) = @@ -206,11 +223,15 @@ Parse.Symbol (getAnn' $ newtypeDeclaration ^. typeDefinition) (T.unpack properType) + denormalizedDerivedConstraintList = + Parse.SExpression ann' $ Parse.Symbol ann' "list" : + map denormalizeExpression (newtypeDeclaration ^. derivedConstraints) in Parse.SExpression ann' [ Parse.Symbol ann' "newtype" , denormalizedTypeDefinition , denormalizeExpression $ newtypeDeclaration ^. wrappedType + , denormalizedDerivedConstraintList ] denormalizeStatement (SPragma pragma) = let ann' = getAnn' pragma @@ -252,7 +273,8 @@ (Parse.Symbol ann' "class" : Parse.SExpression ann' - (map denormalizeExpression (typeclassDefinition ^. constraints)) : + (Parse.Symbol ann' "list" : + map denormalizeExpression (typeclassDefinition ^. constraints)) : denormalizeExpression (typeclassDefinition ^. name) : map (denormalizeStatement . STypeSignature) @@ -264,7 +286,8 @@ (Parse.Symbol ann' "instance" : Parse.SExpression ann' - (map denormalizeExpression (typeclassInstance ^. constraints)) : + (Parse.Symbol ann' "list" : + map denormalizeExpression (typeclassInstance ^. constraints)) : denormalizeExpression (typeclassInstance ^. instanceName) : map (denormalizeStatement . SFunctionDefinition) @@ -277,7 +300,8 @@ , Parse.Symbol ann' (T.unpack $ typeSig ^. name) , Parse.SExpression ann' - (map denormalizeExpression (typeSig ^. constraints)) + (Parse.Symbol ann' "list" : + map denormalizeExpression (typeSig ^. constraints)) , denormalizeExpression (typeSig ^. typeDefinition) ] denormalizeStatement (STypeSynonym typeSynonym) = diff --git a/src/Axel/Eff.hs b/src/Axel/Eff.hs --- a/src/Axel/Eff.hs +++ b/src/Axel/Eff.hs @@ -1,7 +1,22 @@ module Axel.Eff where -import qualified Polysemy as Sem +import Data.Kind +import Effectful ((:>), Eff) + +-- This is being removed from effectful proper for performance reasons +-- (see https://github.com/haskell-effectful/effectful/issues/52#issuecomment-1269155485), +-- but it's not an issue for us (at least not for the moment). +-- Adapted from https://github.com/haskell-effectful/effectful/blob/0e312c77f49edb5f3d74cb70bf3fc0d9cd1816ff/effectful-core/src/Effectful/Internal/Effect.hs. +-- | Convenience operator for expressing that a function uses multiple effects +-- in a more concise way than enumerating them all with '(:>)'. +-- +-- @[E1, E2, ..., En] ':>>' es ≡ (E1 ':>' es, E2 ':>' es, ..., En :> es)@ +type family xs :>> es :: Constraint where + '[] :>> _es = () + (x ': xs) :>> es = (x :> es, xs :>> es) + type Callback effs fn a - = forall openEffs. (Sem.Members effs openEffs) => - fn (Sem.Sem openEffs a) + = forall openEffs. (effs :>> openEffs) => + fn (Eff openEffs a) + diff --git a/src/Axel/Eff/App.hs b/src/Axel/Eff/App.hs --- a/src/Axel/Eff/App.hs +++ b/src/Axel/Eff/App.hs @@ -5,27 +5,28 @@ import Axel.Eff.Console (Console, runConsole) import Axel.Eff.Error (Error, renderError, unsafeRunError) import Axel.Eff.FileSystem (FileSystem, runFileSystem) -import Axel.Eff.Ghci (Ghci, runStackGhci) +import Axel.Eff.Ghci (Ghci, runGhci) import Axel.Eff.Log (Log, runLogAsFileSystem) import Axel.Eff.Process (Process, runProcess) import Axel.Eff.Random (Random, runRandom) import Axel.Eff.Resource (Resource, runResource) import Axel.Eff.Time (Time, runTime) -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff type AppEffs - = '[ Log, Console, Sem.Error Error, FileSystem, Ghci, Process, Resource, Random, Time, Sem.Embed IO] + = '[ Eff.Error Error, Log, Console, FileSystem, Ghci, Process, Resource, Random, Time, Eff.IOE] -runApp :: Sem.Sem AppEffs a -> IO a +runApp :: Eff.Eff AppEffs a -> IO a runApp = - Sem.runM . + Eff.runEff . runTime . runRandom . runResource . runProcess . - runStackGhci . + runGhci . runFileSystem . - unsafeRunError renderError . - runConsole . runLogAsFileSystem (FilePath "axelCompilation.log") + runConsole . + runLogAsFileSystem (FilePath "axelCompilation.log") . + unsafeRunError renderError diff --git a/src/Axel/Eff/Console.hs b/src/Axel/Eff/Console.hs --- a/src/Axel/Eff/Console.hs +++ b/src/Axel/Eff/Console.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Eff.Console where @@ -9,29 +7,30 @@ import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified Polysemy as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff +import qualified Effectful.TH as Eff import qualified System.Console.ANSI as ANSI (getTerminalSize) -data Console m a where +data Console :: Eff.Effect where GetTerminalSize :: Console m (Maybe (Int, Int)) PutStr :: Text -> Console m () -Sem.makeSem ''Console +Eff.makeEffect ''Console -runConsole :: - (Sem.Member (Sem.Embed IO) effs) - => Sem.Sem (Console ': effs) a - -> Sem.Sem effs a +runConsole :: (Eff.IOE :> effs) => Eff.Eff (Console ': effs) a -> Eff.Eff effs a runConsole = - Sem.interpret $ \case - GetTerminalSize -> Sem.embed ANSI.getTerminalSize - PutStr str -> Sem.embed $ T.putStr str + Eff.interpret $ \_ -> + \case + GetTerminalSize -> Eff.liftIO ANSI.getTerminalSize + PutStr str -> Eff.liftIO $ T.putStr str -putStrLn :: (Sem.Member Console effs) => Text -> Sem.Sem effs () +putStrLn :: (Console :> effs) => Text -> Eff.Eff effs () putStrLn = putStr . (<> "\n") -putHorizontalLine :: (Sem.Member Console effs) => Sem.Sem effs () +putHorizontalLine :: (Console :> effs) => Eff.Eff effs () putHorizontalLine = do maybeTerminalSize <- getTerminalSize case maybeTerminalSize of diff --git a/src/Axel/Eff/Error.hs b/src/Axel/Eff/Error.hs --- a/src/Axel/Eff/Error.hs +++ b/src/Axel/Eff/Error.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Axel.Eff.Error where import Axel.Prelude @@ -11,11 +8,10 @@ import Control.Monad ((>=>)) -import Data.Semigroup ((<>)) import qualified Data.Text as T -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff data Error where ConvertError :: FilePath -> Text -> Error @@ -52,6 +48,6 @@ fatal context message = error $ "[FATAL] " <> context <> " - " <> message unsafeRunError :: - Renderer e -> Sem.Sem (Sem.Error e ': effs) a -> Sem.Sem effs a + Renderer e -> Eff.Eff (Eff.Error e ': effs) a -> Eff.Eff effs a unsafeRunError render = - Sem.runError >=> either (errorWithoutStackTrace . render) pure -- TODO Don't(?) use `error(WithoutStackTrace)` directly + Eff.runErrorNoCallStack >=> either (errorWithoutStackTrace . render) pure -- TODO Don't(?) use `error(WithoutStackTrace)` directly diff --git a/src/Axel/Eff/FileSystem.hs b/src/Axel/Eff/FileSystem.hs --- a/src/Axel/Eff/FileSystem.hs +++ b/src/Axel/Eff/FileSystem.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Eff.FileSystem where import Axel.Prelude +import Axel.Utils.FilePath (()) + import Control.Monad (forM) import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified Polysemy as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff +import qualified Effectful.TH as Eff -import Axel.Utils.FilePath (()) import qualified System.Directory ( copyFile , createDirectoryIfMissing @@ -25,7 +27,7 @@ , setCurrentDirectory ) -data FileSystem m a where +data FileSystem :: Eff.Effect where AppendFile :: FilePath -> Text -> FileSystem m () CopyFile :: FilePath -> FilePath -> FileSystem m () CreateDirectoryIfMissing :: Bool -> FilePath -> FileSystem m () @@ -38,46 +40,44 @@ SetCurrentDirectory :: FilePath -> FileSystem m () WriteFile :: FilePath -> Text -> FileSystem m () -Sem.makeSem ''FileSystem +Eff.makeEffect ''FileSystem runFileSystem :: - (Sem.Member (Sem.Embed IO) effs) - => Sem.Sem (FileSystem ': effs) a - -> Sem.Sem effs a + (Eff.IOE :> effs) => Eff.Eff (FileSystem ': effs) a -> Eff.Eff effs a runFileSystem = - Sem.interpret - (\case - AppendFile (FilePath path) contents -> - Sem.embed $ T.appendFile (T.unpack path) contents - CopyFile (FilePath src) (FilePath dest) -> - Sem.embed $ System.Directory.copyFile (T.unpack src) (T.unpack dest) - CreateDirectoryIfMissing createParentDirs (FilePath path) -> - Sem.embed $ - System.Directory.createDirectoryIfMissing - createParentDirs - (T.unpack path) - DoesDirectoryExist (FilePath path) -> - Sem.embed $ System.Directory.doesDirectoryExist (T.unpack path) - GetCurrentDirectory -> - Sem.embed $ FilePath . T.pack <$> System.Directory.getCurrentDirectory - GetDirectoryContents (FilePath path) -> - Sem.embed $ - map (FilePath . T.pack) <$> - System.Directory.getDirectoryContents (T.unpack path) - GetTemporaryDirectory -> - Sem.embed $ - FilePath . T.pack <$> System.Directory.getTemporaryDirectory - ReadFile (FilePath path) -> Sem.embed $ T.readFile (T.unpack path) - RemoveFile (FilePath path) -> - Sem.embed $ System.Directory.removeFile (T.unpack path) - SetCurrentDirectory (FilePath path) -> - Sem.embed $ System.Directory.setCurrentDirectory (T.unpack path) - WriteFile (FilePath path) contents -> - Sem.embed $ T.writeFile (T.unpack path) contents) + Eff.interpret $ \_ -> + \case + AppendFile (FilePath path) contents -> + Eff.liftIO $ T.appendFile (T.unpack path) contents + CopyFile (FilePath src) (FilePath dest) -> + Eff.liftIO $ System.Directory.copyFile (T.unpack src) (T.unpack dest) + CreateDirectoryIfMissing createParentDirs (FilePath path) -> + Eff.liftIO $ + System.Directory.createDirectoryIfMissing + createParentDirs + (T.unpack path) + DoesDirectoryExist (FilePath path) -> + Eff.liftIO $ System.Directory.doesDirectoryExist (T.unpack path) + GetCurrentDirectory -> + Eff.liftIO $ FilePath . T.pack <$> System.Directory.getCurrentDirectory + GetDirectoryContents (FilePath path) -> + Eff.liftIO $ + map (FilePath . T.pack) <$> + System.Directory.getDirectoryContents (T.unpack path) + GetTemporaryDirectory -> + Eff.liftIO $ + FilePath . T.pack <$> System.Directory.getTemporaryDirectory + ReadFile (FilePath path) -> Eff.liftIO $ T.readFile (T.unpack path) + RemoveFile (FilePath path) -> + Eff.liftIO $ System.Directory.removeFile (T.unpack path) + SetCurrentDirectory (FilePath path) -> + Eff.liftIO $ System.Directory.setCurrentDirectory (T.unpack path) + WriteFile (FilePath path) contents -> + Eff.liftIO $ T.writeFile (T.unpack path) contents -- Adapted from http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html. getDirectoryContentsRec :: - (Sem.Member FileSystem effs) => FilePath -> Sem.Sem effs [FilePath] + (FileSystem :> effs) => FilePath -> Eff.Eff effs [FilePath] getDirectoryContentsRec dir = do names <- getDirectoryContents dir let properNames = @@ -92,10 +92,7 @@ pure $ concat paths withCurrentDirectory :: - (Sem.Member FileSystem effs) - => FilePath - -> Sem.Sem effs a - -> Sem.Sem effs a + (FileSystem :> effs) => FilePath -> Eff.Eff effs a -> Eff.Eff effs a withCurrentDirectory directory f = do originalDirectory <- getCurrentDirectory setCurrentDirectory directory @@ -104,7 +101,5 @@ pure result withTemporaryDirectory :: - (Sem.Member FileSystem effs) - => (FilePath -> Sem.Sem effs a) - -> Sem.Sem effs a + (FileSystem :> effs) => (FilePath -> Eff.Eff effs a) -> Eff.Eff effs a withTemporaryDirectory action = getTemporaryDirectory >>= action diff --git a/src/Axel/Eff/Ghci.hs b/src/Axel/Eff/Ghci.hs --- a/src/Axel/Eff/Ghci.hs +++ b/src/Axel/Eff/Ghci.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Eff.Ghci where @@ -11,53 +9,49 @@ import qualified Data.Text as T +import Effectful ((:>), Eff, Effect, IOE, liftIO) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.Reader.Static (Reader, runReader) +import Effectful.TH (makeEffect) + import Language.Haskell.Ghcid (startGhci, stopGhci) import qualified Language.Haskell.Ghcid as Ghci -import qualified Polysemy as Sem -import qualified Polysemy.Reader as Sem - -data Ghci m a where +data Ghci :: Effect where Exec :: Ghci.Ghci -> Text -> Ghci m [Text] Start :: Ghci m Ghci.Ghci Stop :: Ghci.Ghci -> Ghci m () -Sem.makeSem ''Ghci +makeEffect ''Ghci -runStackGhci :: - (Sem.Member (Sem.Embed IO) effs) - => Sem.Sem (Ghci ': effs) a - -> Sem.Sem effs a -runStackGhci = - Sem.interpret $ \case - Exec ghci command -> - Sem.embed $ map T.pack <$> Ghci.exec ghci (T.unpack command) - Start -> - Sem.embed $ - fst <$> - startGhci - "stack repl --no-load --ghc-options='-ignore-dot-ghci'" -- We don't want to load any of the project's modules - -- unless a macro explicitly requires them - -- (they might not even have been compiled yet!) - Nothing - mempty - Stop ghci -> Sem.embed $ stopGhci ghci +runGhci :: (IOE :> effs) => Eff (Ghci ': effs) a -> Eff effs a +runGhci = + interpret $ \_ -> + \case + Exec ghci command -> + liftIO $ map T.pack <$> Ghci.exec ghci (T.unpack command) + Start -> + liftIO $ + fst <$> + startGhci + "cabal repl --repl-options='-ignore-dot-ghci'" -- We don't want to load any of the project's modules + -- unless a macro explicitly requires them + -- (they might not even have been compiled yet!) + Nothing + mempty + Stop ghci -> liftIO $ stopGhci ghci -addFiles :: - (Sem.Member Ghci effs) => Ghci.Ghci -> [FilePath] -> Sem.Sem effs [Text] +addFiles :: (Ghci :> effs) => Ghci.Ghci -> [FilePath] -> Eff effs [Text] addFiles ghci filePaths = exec ghci $ ":add " <> T.unwords (map (op FilePath) filePaths) -- TODO What if a file path contains a space? -enableJsonErrors :: (Sem.Member Ghci effs) => Ghci.Ghci -> Sem.Sem effs () +enableJsonErrors :: (Ghci :> effs) => Ghci.Ghci -> Eff effs () enableJsonErrors ghci = void $ exec ghci ":set -ddump-json" -withStackGhci :: - (Sem.Member Ghci effs) - => Sem.Sem (Sem.Reader Ghci.Ghci ': effs) a - -> Sem.Sem effs a -withStackGhci x = do +withGhci :: (Ghci :> effs) => Eff (Reader Ghci.Ghci ': effs) a -> Eff effs a +withGhci x = do ghci <- start enableJsonErrors ghci - result <- Sem.runReader ghci x + result <- runReader ghci x stop ghci pure result diff --git a/src/Axel/Eff/Lens.hs b/src/Axel/Eff/Lens.hs --- a/src/Axel/Eff/Lens.hs +++ b/src/Axel/Eff/Lens.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} - -- NOTE Inspired by `fused-effects-lens`. module Axel.Eff.Lens where @@ -21,68 +19,56 @@ import Data.Profunctor.Unsafe (Profunctor(( #. ))) -import qualified Polysemy as Sem -import qualified Polysemy.Reader as Sem -import qualified Polysemy.State as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Reader.Static as Eff +import qualified Effectful.State.Static.Local as Eff {-# INLINE view #-} -view :: (Sem.Member (Sem.Reader s) effs) => Getting a s a -> Sem.Sem effs a -view l = Sem.asks $ getConst #. l Const +view :: (Eff.Reader s :> effs) => Getting a s a -> Eff.Eff effs a +view l = Eff.asks $ getConst #. l Const {-# INLINE views #-} views :: - (Sem.Member (Sem.Reader s) effs) + (Eff.Reader s :> effs) => LensLike' (Const r) s a -> (a -> r) - -> Sem.Sem effs r -views l f = Sem.asks $ getConst #. l (Const #. f) + -> Eff.Eff effs r +views l f = Eff.asks $ getConst #. l (Const #. f) {-# INLINE use #-} -use :: (Sem.Member (Sem.State s) effs) => Getting a s a -> Sem.Sem effs a -use = Sem.gets . Lens.view +use :: (Eff.State s :> effs) => Getting a s a -> Eff.Eff effs a +use = Eff.gets . Lens.view {-# INLINE uses #-} uses :: - (Sem.Member (Sem.State s) effs) + (Eff.State s :> effs) => LensLike' (Const r) s a -> (a -> r) - -> Sem.Sem effs r -uses l f = Sem.gets $ Lens.views l f + -> Eff.Eff effs r +uses l f = Eff.gets $ Lens.views l f {-# INLINE assign #-} -assign :: - (Sem.Member (Sem.State s) effs) => ASetter s s a b -> b -> Sem.Sem effs () -assign l b = Sem.modify $ set l b +assign :: (Eff.State s :> effs) => ASetter s s a b -> b -> Eff.Eff effs () +assign l b = Eff.modify $ set l b infixr 4 .= {-# INLINE (.=) #-} -(.=) :: - (Sem.Member (Sem.State s) effs) => ASetter s s a b -> b -> Sem.Sem effs () +(.=) :: (Eff.State s :> effs) => ASetter s s a b -> b -> Eff.Eff effs () (.=) = assign {-# INLINE modifying #-} modifying :: - (Sem.Member (Sem.State s) effs) - => ASetter s s a b - -> (a -> b) - -> Sem.Sem effs () -modifying l f = Sem.modify $ over l f + (Eff.State s :> effs) => ASetter s s a b -> (a -> b) -> Eff.Eff effs () +modifying l f = Eff.modify $ over l f infixr 4 %= {-# INLINE (%=) #-} -(%=) :: - (Sem.Member (Sem.State s) effs) - => ASetter s s a b - -> (a -> b) - -> Sem.Sem effs () +(%=) :: (Eff.State s :> effs) => ASetter s s a b -> (a -> b) -> Eff.Eff effs () (%=) = modifying {-# INLINE (<>=) #-} -(<>=) :: - (Sem.Member (Sem.State s) effs, Monoid a) - => ASetter' s a - -> a - -> Sem.Sem effs () -l <>= a = Sem.modify $ l <>~ a +(<>=) :: (Eff.State s :> effs, Monoid a) => ASetter' s a -> a -> Eff.Eff effs () +l <>= a = Eff.modify $ l <>~ a diff --git a/src/Axel/Eff/Log.hs b/src/Axel/Eff/Log.hs --- a/src/Axel/Eff/Log.hs +++ b/src/Axel/Eff/Log.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Eff.Log where @@ -9,35 +7,41 @@ import Axel.Eff.Console (Console, putStr) import Axel.Eff.FileSystem (FileSystem, appendFile, writeFile) -import qualified Polysemy as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff +import qualified Effectful.TH as Eff -data Log m a where +data Log :: Eff.Effect where LogStr :: Text -> Log m () -Sem.makeSem ''Log +Eff.makeEffect ''Log runLogAsConsole :: - (Sem.Member Console effs) => Sem.Sem (Log ': effs) a -> Sem.Sem effs a + (Console :> effs) => Eff.Eff (Log ': effs) a -> Eff.Eff effs a runLogAsConsole = - Sem.interpret $ \case - LogStr str -> putStr str + Eff.interpret $ \_ -> + \case + LogStr str -> putStr str runLogAsFileSystem :: - (Sem.Member FileSystem effs) + (FileSystem :> effs) => FilePath - -> Sem.Sem (Log ': effs) a - -> Sem.Sem effs a + -> Eff.Eff (Log ': effs) a + -> Eff.Eff effs a runLogAsFileSystem logFilePath action = do writeFile logFilePath "" - Sem.interpret - (\case - LogStr str -> appendFile logFilePath str) + Eff.interpret + (\_ -> + \case + LogStr str -> appendFile logFilePath str) action -ignoreLog :: Sem.Sem (Log ': effs) a -> Sem.Sem effs a +ignoreLog :: Eff.Eff (Log ': effs) a -> Eff.Eff effs a ignoreLog = - Sem.interpret $ \case - LogStr _ -> pure () + Eff.interpret $ \_ -> + \case + LogStr _ -> pure () -logStrLn :: (Sem.Member Log effs) => Text -> Sem.Sem effs () +logStrLn :: (Log :> effs) => Text -> Eff.Eff effs () logStrLn str = logStr (str <> "\n") diff --git a/src/Axel/Eff/Loop.hs b/src/Axel/Eff/Loop.hs --- a/src/Axel/Eff/Loop.hs +++ b/src/Axel/Eff/Loop.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- Inspired by http://www.haskellforall.com/2012/07/breaking-from-loop.html. module Axel.Eff.Loop where @@ -8,16 +5,17 @@ import Control.Monad (void) -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff -type Loop a = Sem.Error a +type Loop a = Eff.Error a breakLoop :: - forall a effs. (Sem.Member (Loop a) effs) + forall a effs. (Loop a :> effs) => a - -> Sem.Sem effs () -breakLoop = void . Sem.throw + -> Eff.Eff effs () +breakLoop = void . Eff.throwError -runLoop :: forall a effs. Sem.Sem (Loop a ': effs) a -> Sem.Sem effs a -runLoop x = either id id <$> Sem.runError x +runLoop :: forall a effs. Eff.Eff (Loop a ': effs) a -> Eff.Eff effs a +runLoop x = either id id <$> Eff.runErrorNoCallStack x diff --git a/src/Axel/Eff/Process.hs b/src/Axel/Eff/Process.hs --- a/src/Axel/Eff/Process.hs +++ b/src/Axel/Eff/Process.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Eff.Process where @@ -10,14 +8,17 @@ import qualified Data.Text as T -import qualified Polysemy as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff +import qualified Effectful.TH as Eff import qualified System.Environment (getArgs) import System.Exit (ExitCode) import System.IO (Handle, hGetContents, hGetLine, hIsEOF) import qualified System.Process as P -data Process m a where +data Process :: Eff.Effect where CreateIndependentProcess :: Text -> Process m (Handle, Handle, Handle, P.ProcessHandle) CreatePassthroughProcess :: Text -> Process m P.ProcessHandle @@ -27,39 +28,36 @@ HandleIsAtEnd :: Handle -> Process m Bool WaitOnProcess :: P.ProcessHandle -> Process m ExitCode -Sem.makeSem ''Process +Eff.makeEffect ''Process -runProcess :: - (Sem.Member (Sem.Embed IO) effs) - => Sem.Sem (Process ': effs) a - -> Sem.Sem effs a +runProcess :: (Eff.IOE :> effs) => Eff.Eff (Process ': effs) a -> Eff.Eff effs a runProcess = - Sem.interpret $ \case - CreateIndependentProcess cmd -> - Sem.embed $ do - let config = - (P.shell (T.unpack cmd)) - { P.std_in = P.CreatePipe - , P.std_out = P.CreatePipe - , P.std_err = P.CreatePipe - } - -- The handles will always be created because of `CreatePipe`, so we can safely unwrap them. - (Just stdinHandle, Just stdoutHandle, Just stderrHandle, processHandle) <- - P.createProcess config - pure (stdinHandle, stdoutHandle, stderrHandle, processHandle) - CreatePassthroughProcess cmd -> - Sem.embed $ do - let config = P.shell (T.unpack cmd) - (_, _, _, processHandle) <- P.createProcess config - pure processHandle - GetArgs -> Sem.embed $ map T.pack <$> System.Environment.getArgs - HandleGetContents handle -> Sem.embed $ T.pack <$> hGetContents handle - HandleGetLine handle -> Sem.embed $ T.pack <$> hGetLine handle - HandleIsAtEnd handle -> Sem.embed $ hIsEOF handle - WaitOnProcess processHandle -> Sem.embed $ P.waitForProcess processHandle + Eff.interpret $ \_ -> + \case + CreateIndependentProcess cmd -> + Eff.liftIO $ do + let config = + (P.shell (T.unpack cmd)) + { P.std_in = P.CreatePipe + , P.std_out = P.CreatePipe + , P.std_err = P.CreatePipe + } + -- The handles will always be created because of `CreatePipe`, so we can safely unwrap them. + (Just stdinHandle, Just stdoutHandle, Just stderrHandle, processHandle) <- + P.createProcess config + pure (stdinHandle, stdoutHandle, stderrHandle, processHandle) + CreatePassthroughProcess cmd -> + Eff.liftIO $ do + let config = P.shell (T.unpack cmd) + (_, _, _, processHandle) <- P.createProcess config + pure processHandle + GetArgs -> Eff.liftIO $ map T.pack <$> System.Environment.getArgs + HandleGetContents handle -> Eff.liftIO $ T.pack <$> hGetContents handle + HandleGetLine handle -> Eff.liftIO $ T.pack <$> hGetLine handle + HandleIsAtEnd handle -> Eff.liftIO $ hIsEOF handle + WaitOnProcess processHandle -> Eff.liftIO $ P.waitForProcess processHandle -readProcess :: - (Sem.Member Process effs) => Text -> Sem.Sem effs (ExitCode, Text, Text) +readProcess :: (Process :> effs) => Text -> Eff.Eff effs (ExitCode, Text, Text) readProcess cmd = do (_, stdoutHandle, stderrHandle, processHandle) <- createIndependentProcess cmd exitCode <- waitOnProcess processHandle @@ -67,5 +65,5 @@ stderr <- handleGetContents stderrHandle pure (exitCode, stdout, stderr) -passthroughProcess :: (Sem.Member Process effs) => Text -> Sem.Sem effs ExitCode +passthroughProcess :: (Process :> effs) => Text -> Eff.Eff effs ExitCode passthroughProcess = createPassthroughProcess >=> waitOnProcess diff --git a/src/Axel/Eff/Random.hs b/src/Axel/Eff/Random.hs --- a/src/Axel/Eff/Random.hs +++ b/src/Axel/Eff/Random.hs @@ -1,24 +1,22 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Eff.Random where import Axel.Prelude -import qualified Polysemy as Sem +import Effectful ((:>), Eff, Effect, IOE, liftIO) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.TH (makeEffect) import qualified System.Random as R -data Random m a where +data Random :: Effect where Random :: (R.Random a) => Random m a -Sem.makeSem ''Random +makeEffect ''Random -runRandom :: - (Sem.Member (Sem.Embed IO) effs) - => Sem.Sem (Random ': effs) a - -> Sem.Sem effs a +runRandom :: (IOE :> effs) => Eff (Random ': effs) a -> Eff effs a runRandom = - Sem.interpret $ \case - (Random :: Random m a) -> Sem.embed $ R.randomIO @a + interpret $ \_ -> + \case + Random -> liftIO R.randomIO diff --git a/src/Axel/Eff/Resource.hs b/src/Axel/Eff/Resource.hs --- a/src/Axel/Eff/Resource.hs +++ b/src/Axel/Eff/Resource.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Eff.Resource where import Axel.Prelude +import Axel.Eff ((:>>)) import Axel.Eff.FileSystem as FS (FileSystem, readFile) import Axel.Utils.FilePath (()) @@ -14,34 +13,35 @@ import Data.Text.Lens (unpacked) -import qualified Polysemy as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff +import qualified Effectful.TH as Eff import qualified Paths_axel as Paths (getDataFileName) newtype ResourceId = ResourceId Text -data Resource m a where +data Resource :: Eff.Effect where GetResourcePath :: ResourceId -> Resource m FilePath -Sem.makeSem ''Resource +Eff.makeEffect ''Resource getDataFileName :: FilePath -> IO FilePath getDataFileName = _Wrapping' FilePath (unpacked Paths.getDataFileName) runResource :: - (Sem.Member (Sem.Embed IO) effs) - => Sem.Sem (Resource ': effs) a - -> Sem.Sem effs a + (Eff.IOE :> effs) => Eff.Eff (Resource ': effs) a -> Eff.Eff effs a runResource = - Sem.interpret $ \case - GetResourcePath (ResourceId resource) -> - Sem.embed $ getDataFileName (FilePath "resources" FilePath resource) + Eff.interpret $ \_ -> + \case + GetResourcePath (ResourceId resource) -> + Eff.liftIO $ + getDataFileName (FilePath "resources" FilePath resource) readResource :: - (Sem.Members '[ FileSystem, Resource] effs) - => ResourceId - -> Sem.Sem effs Text + ('[ FileSystem, Resource] :>> effs) => ResourceId -> Eff.Eff effs Text readResource = getResourcePath >=> FS.readFile newProjectTemplate :: ResourceId diff --git a/src/Axel/Eff/Restartable.hs b/src/Axel/Eff/Restartable.hs --- a/src/Axel/Eff/Restartable.hs +++ b/src/Axel/Eff/Restartable.hs @@ -1,20 +1,17 @@ -{-# LANGUAGE GADTs #-} - module Axel.Eff.Restartable where import Axel.Prelude -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import Effectful ((:>), Eff) +import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) -type Restartable = Sem.Error +type Restartable = Error -restart :: (Sem.Member (Restartable a) effs) => a -> Sem.Sem effs () -restart = Sem.throw +restart :: (Restartable a :> effs) => a -> Eff effs () +restart = throwError -runRestartable :: - a -> (a -> Sem.Sem (Restartable a ': effs) a) -> Sem.Sem effs a +runRestartable :: a -> (a -> Eff (Restartable a ': effs) a) -> Eff effs a runRestartable x f = - Sem.runError (f x) >>= \case + runErrorNoCallStack (f x) >>= \case Left x' -> runRestartable x' f Right x' -> pure x' diff --git a/src/Axel/Eff/Time.hs b/src/Axel/Eff/Time.hs --- a/src/Axel/Eff/Time.hs +++ b/src/Axel/Eff/Time.hs @@ -1,39 +1,39 @@ {- HLINT ignore "Avoid restricted function" -} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Eff.Time where import Axel.Prelude +import Axel.Eff ((:>>)) import qualified Axel.Eff.Console as Effs import Axel.Eff.Unsafe (unsafeEmbedIO) import qualified Data.Text as T import qualified Data.Time as Time -import qualified Polysemy as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff +import qualified Effectful.TH as Eff -data Time m a where +data Time :: Eff.Effect where GetCurrentTime :: Time m Time.UTCTime -Sem.makeSem ''Time +Eff.makeEffect ''Time -runTime :: - (Sem.Member (Sem.Embed IO) effs) - => Sem.Sem (Time ': effs) a - -> Sem.Sem effs a +runTime :: (Eff.IOE :> effs) => Eff.Eff (Time ': effs) a -> Eff.Eff effs a runTime = - Sem.interpret $ \case - GetCurrentTime -> Sem.embed Time.getCurrentTime + Eff.interpret $ \_ -> + \case + GetCurrentTime -> Eff.liftIO Time.getCurrentTime -- | Only use for debugging purposes. reportTime :: - (Sem.Members '[ Effs.Console, Time] effs) + ('[ Effs.Console, Time] :>> effs) => Text - -> Sem.Sem effs a - -> Sem.Sem effs a + -> Eff.Eff effs a + -> Eff.Eff effs a reportTime message x = do startTime <- getCurrentTime result <- x @@ -48,7 +48,7 @@ unsafeReportTime :: Text - -> Sem.Sem (Time ': Effs.Console ': Sem.Embed IO ': effs) a - -> Sem.Sem effs a + -> Eff.Eff (Time ': Effs.Console ': Eff.IOE ': effs) a + -> Eff.Eff effs a unsafeReportTime message = unsafeEmbedIO . Effs.runConsole . runTime . reportTime message diff --git a/src/Axel/Eff/Unsafe.hs b/src/Axel/Eff/Unsafe.hs --- a/src/Axel/Eff/Unsafe.hs +++ b/src/Axel/Eff/Unsafe.hs @@ -1,15 +1,9 @@ {- HLINT ignore "Avoid restricted function" -} module Axel.Eff.Unsafe where -import Axel.Prelude - -import qualified Polysemy as Sem +import Effectful (Eff, IOE) -import System.IO.Unsafe (unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce) -unsafeEmbedIO :: Sem.Sem (Sem.Embed IO ': effs) a -> Sem.Sem effs a -unsafeEmbedIO = - Sem.interpret $ \case - Sem.Embed x -> do - let !result = unsafePerformIO x - pure result +unsafeEmbedIO :: Eff (IOE ': effs) a -> Eff effs a +unsafeEmbedIO = unsafeCoerce diff --git a/src/Axel/Haskell/Cabal.hs b/src/Axel/Haskell/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Axel/Haskell/Cabal.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Axel.Haskell.Cabal where + +import Axel.Prelude + +import Axel.Eff ((:>>)) +import Axel.Eff.Console (putStr, putStrLn) +import qualified Axel.Eff.Console as Effs +import Axel.Eff.Error (Error(ProjectError), fatal) +import qualified Axel.Eff.FileSystem as FS +import qualified Axel.Eff.FileSystem as Effs +import Axel.Eff.Process + ( createIndependentProcess + , handleGetLine + , handleIsAtEnd + , passthroughProcess + , readProcess + , waitOnProcess + ) +import qualified Axel.Eff.Process as Effs +import Axel.Haskell.Error (processStackOutputLine) +import Axel.Sourcemap (ModuleInfo) +import Axel.Utils.FilePath (takeFileName) +import Axel.Utils.Monad (whileM) + +import Control.Lens (op) +import Control.Lens.Operators ((%~), (^?!)) +import Control.Monad (void) + +import Data.Aeson.Key (toText) +import Data.Aeson.KeyMap (keys) +import Data.Aeson.Lens (_Array, _Object, key) +import Data.Function ((&)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Vector (cons) +import Data.Version (showVersion) +import qualified Data.Yaml as Yaml + +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff + +import Paths_axel (version) + +import System.Exit (ExitCode(ExitFailure, ExitSuccess)) + +type ProjectPath = FilePath + +type StackageId = Text + +type StackageResolver = Text + +type Target = Text + +type Version = Text + +axelVersion :: Version +axelVersion = T.pack $ showVersion version + +axelPackageId :: StackageId +axelPackageId = "axel" + +getProjectExecutableTargets :: + (Effs.FileSystem :> effs) => ProjectPath -> Eff.Eff effs [Target] +getProjectExecutableTargets projectPath = + FS.withCurrentDirectory projectPath $ do + config <- readPackageConfig + pure $ map toText $ keys $ config ^?! key "executables" . _Object + +packageConfigRelativePath :: FilePath +packageConfigRelativePath = FilePath "package.yaml" + +readPackageConfig :: (Effs.FileSystem :> effs) => Eff.Eff effs Yaml.Value +readPackageConfig = do + packageConfigContents <- FS.readFile packageConfigRelativePath + case Yaml.decodeEither' $ T.encodeUtf8 packageConfigContents of + Right contents -> pure contents + Left _ -> fatal "readPackageConfig" "0001" + +addDependency :: + (Effs.FileSystem :> effs) => StackageId -> ProjectPath -> Eff.Eff effs () +addDependency dependencyId projectPath = + FS.withCurrentDirectory projectPath $ do + config <- readPackageConfig + let newContents :: Yaml.Value = + config & key "dependencies" . _Array %~ + cons (Yaml.String dependencyId) + encodedContents = T.decodeUtf8 $ Yaml.encode newContents + FS.writeFile packageConfigRelativePath encodedContents + +buildProject :: + ('[ Effs.Console, Eff.Error Error, Effs.FileSystem, Effs.Process] :>> effs) + => ModuleInfo + -> ProjectPath + -> Eff.Eff effs () +buildProject moduleInfo projectPath = do + FS.withCurrentDirectory projectPath $ do + putStrLn ("Building " <> op FilePath (takeFileName projectPath) <> "...") + (_, _, stderrHandle, processHandle) <- + createIndependentProcess "cabal build --ghc-options='-ddump-json'" + whileM (not <$> handleIsAtEnd stderrHandle) $ do + stackOutputLine <- handleGetLine stderrHandle + putStr $ T.unlines $ processStackOutputLine moduleInfo stackOutputLine + exitCode <- waitOnProcess processHandle + case exitCode of + ExitSuccess -> pure () + ExitFailure _ -> Eff.throwError $ ProjectError "Project failed to build." + +createProject :: + ('[ Effs.FileSystem, Effs.Process] :>> effs) => Text -> Eff.Eff effs () +createProject projectName = + void $ readProcess ("cabal new " <> projectName <> " new-template") + +runProject :: + ('[ Effs.Console, Eff.Error Error, Effs.FileSystem, Effs.Process] :>> effs) + => ProjectPath + -> Eff.Eff effs () +runProject projectPath = do + targets <- getProjectExecutableTargets projectPath + case targets of + [target] -> do + putStrLn $ "Running " <> target <> "..." + void $ passthroughProcess ("cabal run " <> target) + _ -> + Eff.throwError $ + ProjectError "No executable target was unambiguously found!" + +includeAxelArguments :: Text +includeAxelArguments = T.unwords ["--package", axelPackageId] diff --git a/src/Axel/Haskell/Convert.hs b/src/Axel/Haskell/Convert.hs --- a/src/Axel/Haskell/Convert.hs +++ b/src/Axel/Haskell/Convert.hs @@ -1,5 +1,4 @@ -- TODO Integrate with the effects system used everywhere else (convert `error` to `throwError`, etc.) -{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-} @@ -8,31 +7,22 @@ import Axel.Prelude import qualified Axel.AST as AST -import Axel.Denormalize (denormalizeExpression, denormalizeStatement) +import Axel.Denormalize (denormalizeStatement) +import Axel.Eff ((:>>)) import Axel.Eff.Console (putStrLn) import qualified Axel.Eff.Console as Effs (Console) -import Axel.Eff.Error (Error(ConvertError), fatal) +import Axel.Eff.Error (Error(ConvertError)) import qualified Axel.Eff.FileSystem as Effs (FileSystem) import qualified Axel.Eff.FileSystem as FS -import qualified Axel.Parse.AST as Parse import Axel.Pretty (prettifyProgram) -import qualified Axel.Sourcemap as SM -import Axel.Utils.List (removeOut, stablyGroupAllWith) -import Axel.Utils.Tuple (flattenAnnotations, unannotated) -import Control.Category ((>>>)) -import Control.Lens (op) -import Control.Lens.Extras (is) -import Control.Lens.Operators ((%~), (^.)) +import Control.Lens ((%~), op) import Data.Data.Lens (biplate, uniplate) -import Data.Maybe (fromMaybe) import qualified Data.Text as T -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem - -import qualified Data.List.NonEmpty as NE +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff import qualified Language.Haskell.Exts as HSE @@ -62,27 +52,26 @@ in sym convertFile :: - (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error, Effs.FileSystem] effs) + ('[ Effs.Console, Effs.FileSystem, Eff.Error Error, Effs.FileSystem] :>> effs) => FilePath -> FilePath - -> Sem.Sem effs FilePath + -> Eff.Eff effs FilePath convertFile path newPath = do originalContents <- FS.readFile path parsedModule <- case HSE.parse @(HSE.Module HSE.SrcSpanInfo) (T.unpack originalContents) of HSE.ParseOk parsedModule -> pure parsedModule - HSE.ParseFailed _ err -> Sem.throw $ ConvertError path (T.pack err) + HSE.ParseFailed _ err -> Eff.throwError $ ConvertError path (T.pack err) putStrLn $ "Writing " <> op FilePath newPath <> "..." let newContents = prettifyProgram $ - groupFunctionDefinitions $ flattenFunctionApplications [] + map denormalizeStatement $ flattenFunctionApplications [] FS.writeFile newPath newContents _ <- error "Haskell to Axel conversion is in construction, see https://app.gitkraken.com/glo/board/Wunz108ztxUAEpyt/card/XYmtRxPb5QAPb0H9." pure newPath --- convertFile path newPath = do flattenFunctionApplications :: [AST.SMStatement] -> [AST.SMStatement] flattenFunctionApplications = map (biplate %~ (uniplate %~ handleExpr)) where @@ -90,44 +79,3 @@ handleExpr (AST.EFunctionApplication (AST.FunctionApplication ann (AST.EFunctionApplication (AST.FunctionApplication _ fn args)) args')) = AST.EFunctionApplication $ AST.FunctionApplication ann fn (args <> args') handleExpr x = x - -groupFunctionDefinitions :: [AST.SMStatement] -> [SM.Expression] -groupFunctionDefinitions = - let findFnName (AST.SFunctionDefinition fnDef) = Just $ fnDef ^. AST.name - findFnName (AST.STypeSignature tySig) = Just $ tySig ^. AST.name - findFnName _ = Nothing - extractTySig :: - ([AST.SMStatement], Maybe Text) - -> (([AST.SMStatement], [AST.SMStatement]), Maybe Text) - extractTySig = unannotated %~ removeOut (is AST._STypeSignature) - transformFnDef (AST.SFunctionDefinition fnDef) = - let whereBindings = - case map denormalizeStatement (fnDef ^. AST.whereBindings) of - [] -> [] - xs -> [Parse.SExpression Nothing xs] - in Parse.SExpression Nothing $ - [ Parse.SExpression Nothing $ - map denormalizeExpression (fnDef ^. AST.arguments) - , denormalizeExpression (fnDef ^. AST.body) - ] <> - whereBindings - transformFnDef _ = fatal "groupFunctionDefinitions" "0001" - in stablyGroupAllWith findFnName >>> - map (flattenAnnotations . extractTySig . (unannotated %~ NE.toList)) >>> - concatMap - (\(stmts, (tySigs, maybeFnName)) -> - fromMaybe (map denormalizeStatement stmts) $ do - fnName <- maybeFnName - case tySigs of - [] -> Nothing - [AST.STypeSignature tySig] -> - Just - [ Parse.SExpression Nothing $ - Parse.Symbol Nothing "def" : - Parse.Symbol Nothing (T.unpack fnName) : - denormalizeExpression (tySig ^. AST.typeDefinition) : - map transformFnDef stmts - ] - _ -> - error $ - "Multiple type signatures found for: `" <> fnName <> "`!") diff --git a/src/Axel/Haskell/File.hs b/src/Axel/Haskell/File.hs --- a/src/Axel/Haskell/File.hs +++ b/src/Axel/Haskell/File.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Axel.Haskell.File where import Axel.Prelude @@ -11,6 +8,7 @@ , ToHaskell(toHaskell) , statementsToProgram ) +import Axel.Eff ((:>>)) import Axel.Eff.Console (putStrLn) import qualified Axel.Eff.Console as Effs (Console) import Axel.Eff.Error (Error) @@ -40,20 +38,19 @@ import Control.Lens (op) import Control.Lens.Operators ((<&>), (?~)) import Control.Lens.Tuple (_2) -import Control.Monad (forM, mapM, unless, void) +import Control.Monad (forM, unless, void) import Data.Data (Data) import qualified Data.Map as M (adjust, fromList, lookup) import Data.Maybe (catMaybes) import Data.Monoid (Alt(Alt)) -import Data.Semigroup ((<>)) -import qualified Language.Haskell.Ghcid as Ghci (Ghci) +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.Reader.Static as Eff +import qualified Effectful.State.Static.Local as Eff -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.Reader as Sem -import qualified Polysemy.State as Sem +import qualified Language.Haskell.Ghcid as Ghci (Ghci) convertList :: (Data ann) => Expression ann -> Expression ann convertList = @@ -69,9 +66,9 @@ x -> x readModuleInfo :: - (Sem.Members '[ Sem.Error Error, Effs.FileSystem] effs) + ('[ Eff.Error Error, Effs.FileSystem] :>> effs) => [FilePath] - -> Sem.Sem effs ModuleInfo + -> Eff.Eff effs ModuleInfo readModuleInfo axelFiles = do modules <- forM axelFiles $ \filePath -> do @@ -82,8 +79,8 @@ mconcat . map Alt <$> mapM (\expr -> - Sem.runError - (Sem.runReader filePath $ withExprCtxt $ normalizeStatement expr) <&> \case + Eff.runErrorNoCallStack + (Eff.runReader filePath $ withExprCtxt $ normalizeStatement expr) <&> \case Right (SModuleDeclaration _ moduleId) -> Just (filePath, (moduleId, Nothing)) _ -> Nothing) @@ -93,14 +90,14 @@ transpileSource :: forall effs fileExpanderEffs funAppExpanderEffs. - ( fileExpanderEffs ~ '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] - , funAppExpanderEffs ~ (Sem.Reader FilePath ': Effs.Restartable SM.Expression ': Sem.State [SMStatement] ': fileExpanderEffs) - , Sem.Members '[ Sem.Error Error, Effs.Ghci, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] effs - , Sem.Members fileExpanderEffs effs + ( fileExpanderEffs ~ '[ Effs.Console, Eff.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Eff.Reader Ghci.Ghci, Eff.State ModuleInfo] + , funAppExpanderEffs ~ (Eff.Reader FilePath ': Effs.Restartable SM.Expression ': Eff.State [SMStatement] ': fileExpanderEffs) + , '[ Eff.Error Error, Effs.Ghci, Eff.Reader Ghci.Ghci, Eff.State ModuleInfo] :>> effs + , fileExpanderEffs :>> effs ) => FilePath -> Text - -> Sem.Sem effs SM.Output + -> Eff.Eff effs SM.Output transpileSource filePath source = toHaskell . statementsToProgram <$> (parseSource (Just filePath) source >>= @@ -112,32 +109,32 @@ filePath) convertFileInPlace :: - (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error, Effs.FileSystem] effs) + ('[ Effs.Console, Effs.FileSystem, Eff.Error Error, Effs.FileSystem] :>> effs) => FilePath - -> Sem.Sem effs FilePath + -> Eff.Eff effs FilePath convertFileInPlace path = do let newPath = replaceExtension path "axel" void $ convertFile path newPath pure newPath transpileFile :: - (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] effs) + ('[ Effs.Console, Eff.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Eff.Reader Ghci.Ghci, Eff.State ModuleInfo] :>> effs) => FilePath -> FilePath - -> Sem.Sem effs () + -> Eff.Eff effs () transpileFile path newPath = do fileContents <- FS.readFile path newContents <- transpileSource path fileContents putStrLn $ op FilePath path <> " => " <> op FilePath newPath FS.writeFile newPath (SM.raw newContents) - Sem.modify $ M.adjust (_2 ?~ newContents) path + Eff.modify $ M.adjust (_2 ?~ newContents) path transpileFileInPlace :: - (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] effs) + ('[ Effs.Console, Eff.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Eff.Reader Ghci.Ghci, Eff.State ModuleInfo] :>> effs) => FilePath - -> Sem.Sem effs FilePath + -> Eff.Eff effs FilePath transpileFileInPlace path = do - moduleInfo <- Sem.gets $ M.lookup path + moduleInfo <- Eff.gets $ M.lookup path let alreadyCompiled = case moduleInfo of Just (_, Just _) -> True @@ -147,9 +144,9 @@ pure newPath formatFileInPlace :: - (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error] effs) + ('[ Effs.Console, Effs.FileSystem, Eff.Error Error] :>> effs) => FilePath - -> Sem.Sem effs () + -> Eff.Eff effs () formatFileInPlace path = do contents <- FS.readFile path putStrLn $ "Formatting " <> op FilePath path <> "..." diff --git a/src/Axel/Haskell/Macros.hs b/src/Axel/Haskell/Macros.hs --- a/src/Axel/Haskell/Macros.hs +++ b/src/Axel/Haskell/Macros.hs @@ -1,7 +1,8 @@ module Axel.Haskell.Macros where import Axel -import qualified Prelude as GHCPrelude -import qualified Axel.Parse.AST as AST +import qualified Prelude as AxelRuntime_GHCPrelude +import qualified Axel.Parse.AST as AxelRuntime_AST +import qualified Axel.Sourcemap as AxelRuntime_Sourcemap import Axel.Prelude import Axel.Haskell.Language(isOperator) import qualified Data.Text as T diff --git a/src/Axel/Haskell/Project.hs b/src/Axel/Haskell/Project.hs --- a/src/Axel/Haskell/Project.hs +++ b/src/Axel/Haskell/Project.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Axel.Haskell.Project where import Axel.Prelude +import Axel.Eff ((:>>)) import qualified Axel.Eff.Console as Effs (Console) import Axel.Eff.Error (Error) import Axel.Eff.FileSystem @@ -18,21 +18,22 @@ import qualified Axel.Eff.Ghci as Ghci import qualified Axel.Eff.Log as Effs (Log) import qualified Axel.Eff.Process as Effs (Process) +import Axel.Eff.Process (passthroughProcess) import Axel.Eff.Resource (getResourcePath, newProjectTemplate) import qualified Axel.Eff.Resource as Effs (Resource) +import qualified Axel.Haskell.Cabal as Cabal + ( addDependency + , axelPackageId + , buildProject + , createProject + , runProject + ) import Axel.Haskell.File ( convertFileInPlace , formatFileInPlace , readModuleInfo , transpileFileInPlace ) -import Axel.Haskell.Stack - ( addStackDependency - , axelStackageId - , buildStackProject - , createStackProject - , runStackProject - ) import Axel.Sourcemap (ModuleInfo) import Axel.Utils.FilePath ((<.>), ()) @@ -42,20 +43,21 @@ import qualified Data.Text as T -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.State as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.State.Static.Local as Eff type ProjectPath = FilePath newProject :: - Sem.Members '[ Effs.FileSystem, Effs.Process, Effs.Resource] effs + ('[ Effs.FileSystem, Effs.Process, Effs.Resource] :>> effs) => Text - -> Sem.Sem effs () + -> Eff.Eff effs () newProject projectName = do - createStackProject projectName + Cabal.createProject projectName let projectPath = FilePath projectName - addStackDependency axelStackageId projectPath + Cabal.addDependency Cabal.axelPackageId projectPath templatePath <- getResourcePath newProjectTemplate let copyAxel filePath = do copyFile @@ -75,9 +77,7 @@ | Backend getProjectFiles :: - (Sem.Member Effs.FileSystem effs) - => ProjectFileType - -> Sem.Sem effs [FilePath] + (Effs.FileSystem :> effs) => ProjectFileType -> Eff.Eff effs [FilePath] getProjectFiles fileType = do files <- concatMapM @@ -90,35 +90,34 @@ pure $ filter (\filePath -> ext `T.isSuffixOf` op FilePath filePath) files transpileProject :: - (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource] effs) - => Sem.Sem effs ModuleInfo + ('[ Effs.Console, Eff.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource] :>> effs) + => Eff.Eff effs ModuleInfo transpileProject = - Ghci.withStackGhci $ do + Ghci.withGhci $ do axelFiles <- getProjectFiles Axel initialModuleInfo <- readModuleInfo axelFiles - (moduleInfo, _) <- - Sem.runState initialModuleInfo $ mapM transpileFileInPlace axelFiles - pure moduleInfo + Eff.execState initialModuleInfo $ mapM transpileFileInPlace axelFiles buildProject :: - (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource] effs) - => Sem.Sem effs () + ('[ Effs.Console, Eff.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource] :>> effs) + => Eff.Eff effs () buildProject = do + void $ passthroughProcess "hpack" projectPath <- getCurrentDirectory transpiledFiles <- transpileProject - buildStackProject transpiledFiles projectPath + Cabal.buildProject transpiledFiles projectPath convertProject :: - (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error, Effs.FileSystem, Effs.Process] effs) - => Sem.Sem effs () + ('[ Effs.Console, Effs.FileSystem, Eff.Error Error, Effs.FileSystem, Effs.Process] :>> effs) + => Eff.Eff effs () convertProject = getProjectFiles Backend >>= void . traverse convertFileInPlace runProject :: - (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Process] effs) - => Sem.Sem effs () -runProject = getCurrentDirectory >>= runStackProject + ('[ Effs.Console, Eff.Error Error, Effs.FileSystem, Effs.Process] :>> effs) + => Eff.Eff effs () +runProject = getCurrentDirectory >>= Cabal.runProject formatProject :: - (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error] effs) - => Sem.Sem effs () + ('[ Effs.Console, Effs.FileSystem, Eff.Error Error] :>> effs) + => Eff.Eff effs () formatProject = getProjectFiles Axel >>= void . traverse formatFileInPlace diff --git a/src/Axel/Haskell/Stack.hs b/src/Axel/Haskell/Stack.hs deleted file mode 100644 --- a/src/Axel/Haskell/Stack.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Axel.Haskell.Stack where - -import Axel.Prelude - -import Axel.Eff.Console (putStr, putStrLn) -import qualified Axel.Eff.Console as Effs -import Axel.Eff.Error (Error(ProjectError), fatal) -import qualified Axel.Eff.FileSystem as FS -import qualified Axel.Eff.FileSystem as Effs -import Axel.Eff.Process - ( createIndependentProcess - , handleGetLine - , handleIsAtEnd - , passthroughProcess - , readProcess - , waitOnProcess - ) -import qualified Axel.Eff.Process as Effs -import Axel.Haskell.Error (processStackOutputLine) -import Axel.Parse (Parser) -import Axel.Sourcemap (ModuleInfo) -import Axel.Utils.FilePath (takeFileName) -import Axel.Utils.Monad (whileM) - -import Control.Lens (op) -import Control.Lens.Operators ((%~)) -import Control.Monad (void) - -import Data.Aeson.Lens (_Array, key) -import Data.Function ((&)) -import Data.List (foldl') -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Vector (cons) -import Data.Version (showVersion) -import qualified Data.Yaml as Yaml - -import Paths_axel (version) - -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem - -import System.Exit (ExitCode(ExitFailure, ExitSuccess)) - -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P - -type ProjectPath = FilePath - -type StackageId = Text - -type StackageResolver = Text - -type Target = Text - -type Version = Text - -stackageResolverWithAxel :: StackageResolver -stackageResolverWithAxel = "nightly" - -axelStackageVersion :: Version -axelStackageVersion = T.pack $ showVersion version - -axelStackageId :: StackageId -axelStackageId = "axel" - -getStackProjectTargets :: - (Sem.Members '[ Effs.FileSystem, Effs.Process] effs) - => ProjectPath - -> Sem.Sem effs [Target] -getStackProjectTargets projectPath = - FS.withCurrentDirectory projectPath $ do - (_, _, stderr) <- readProcess "stack ide targets" - pure $ T.lines stderr - -addStackDependency :: - (Sem.Member Effs.FileSystem effs) - => StackageId - -> ProjectPath - -> Sem.Sem effs () -addStackDependency dependencyId projectPath = - FS.withCurrentDirectory projectPath $ do - let packageConfigPath = FilePath "package.yaml" - packageConfigContents <- FS.readFile packageConfigPath - case Yaml.decodeEither' $ T.encodeUtf8 packageConfigContents of - Right contents -> - let newContents :: Yaml.Value = - contents & key "dependencies" . _Array %~ - cons (Yaml.String dependencyId) - encodedContents = T.decodeUtf8 $ Yaml.encode newContents - in FS.writeFile packageConfigPath encodedContents - Left _ -> fatal "addStackDependency" "0001" - -buildStackProject :: - (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Process] effs) - => ModuleInfo - -> ProjectPath - -> Sem.Sem effs () -buildStackProject moduleInfo projectPath = do - FS.withCurrentDirectory projectPath $ do - putStrLn ("Building " <> op FilePath (takeFileName projectPath) <> "...") - (_, _, stderrHandle, processHandle) <- - createIndependentProcess "stack build --ghc-options='-ddump-json'" - whileM (not <$> handleIsAtEnd stderrHandle) $ do - stackOutputLine <- handleGetLine stderrHandle - putStr $ T.unlines $ processStackOutputLine moduleInfo stackOutputLine - exitCode <- waitOnProcess processHandle - case exitCode of - ExitSuccess -> pure () - ExitFailure _ -> Sem.throw $ ProjectError "Project failed to build." - -createStackProject :: - (Sem.Members '[ Effs.FileSystem, Effs.Process] effs) - => Text - -> Sem.Sem effs () -createStackProject projectName = do - void $ readProcess ("stack new " <> projectName <> " new-template") - setStackageResolver (FilePath projectName) stackageResolverWithAxel - -runStackProject :: - (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Process] effs) - => ProjectPath - -> Sem.Sem effs () -runStackProject projectPath = do - targets <- getStackProjectTargets projectPath - case findExeTargets targets of - [target] -> do - putStrLn $ "Running " <> target <> "..." - void $ passthroughProcess ("stack exec " <> target) - _ -> - Sem.throw $ ProjectError "No executable target was unambiguously found!" - where - exeTarget :: Parser Text - exeTarget = - P.many (P.anySingleBut ':') *> P.string ":exe:" *> - (T.pack <$> P.many (P.anySingleBut ':')) - findExeTargets = - foldl' - (\acc target -> - case P.parseMaybe exeTarget target of - Just targetName -> targetName : acc - Nothing -> acc) - [] - -setStackageResolver :: - (Sem.Members '[ Effs.FileSystem, Effs.Process] effs) - => ProjectPath - -> StackageResolver - -> Sem.Sem effs () -setStackageResolver projectPath resolver = - void $ FS.withCurrentDirectory projectPath $ readProcess $ - "stack config set resolver " <> - resolver - -includeAxelArguments :: Text -includeAxelArguments = - T.unwords - ["--resolver", stackageResolverWithAxel, "--package", axelStackageId] diff --git a/src/Axel/Macros.hs b/src/Axel/Macros.hs --- a/src/Axel/Macros.hs +++ b/src/Axel/Macros.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LiberalTypeSynonyms #-} module Axel.Macros where @@ -31,6 +30,7 @@ , statementsToProgram ) import Axel.Denormalize (denormalizeStatement) +import Axel.Eff ((:>>)) import qualified Axel.Eff as Effs import Axel.Eff.Error (Error(MacroError, ParseError), fatal) import qualified Axel.Eff.FileSystem as Effs (FileSystem) @@ -83,15 +83,15 @@ import Data.List.Split (split, whenElt) import qualified Data.Map as M import Data.Maybe (isNothing) -import Data.Semigroup ((<>)) import qualified Data.Text as T import qualified Language.Haskell.Ghcid as Ghcid -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.Reader as Sem -import qualified Polysemy.State as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.Reader.Static as Eff +import qualified Effectful.State.Static.Local as Eff type FunctionApplicationExpanderArgs a = SM.Expression -> a @@ -105,19 +105,19 @@ -- | Fully expand a program, and add macro definition type signatures. processProgram :: forall fileExpanderEffs funAppExpanderEffs effs innerEffs. - ( innerEffs ~ (Sem.State [SMStatement] ': Effs.Restartable SM.Expression ': Sem.Reader FilePath ': effs) - , Sem.Members '[ Sem.Error Error, Effs.Ghci, Sem.Reader Ghcid.Ghci, Sem.State ModuleInfo] effs - , Sem.Members fileExpanderEffs innerEffs - , Sem.Members funAppExpanderEffs innerEffs + ( innerEffs ~ (Eff.State [SMStatement] ': Effs.Restartable SM.Expression ': Eff.Reader FilePath ': effs) + , '[ Eff.Error Error, Effs.Ghci, Eff.Reader Ghcid.Ghci, Eff.State ModuleInfo] :>> effs + , fileExpanderEffs :>> innerEffs + , funAppExpanderEffs :>> innerEffs ) => FunctionApplicationExpander funAppExpanderEffs -> FileExpander fileExpanderEffs -> FilePath -> SM.Expression - -> Sem.Sem effs [SMStatement] + -> Eff.Eff effs [SMStatement] processProgram expandFunApp expandFile filePath program = do newProgramExpr <- - Sem.runReader filePath $ + Eff.runReader filePath $ expandProgramExpr @funAppExpanderEffs @fileExpanderEffs @@ -126,7 +126,7 @@ program newStmts <- mapM - (Sem.runReader filePath . withExprCtxt . normalizeStatement) + (Eff.runReader filePath . withExprCtxt . normalizeStatement) (unwrapCompoundExpressions newProgramExpr) withAstImports <- insertImports filePath (autogeneratedImports filePath) newStmts @@ -161,28 +161,26 @@ macroTySigs isMacroImported :: - (Sem.Member (Sem.State [SMStatement]) effs) - => Identifier - -> Sem.Sem effs Bool + (Eff.State [SMStatement] :> effs) => Identifier -> Eff.Eff effs Bool isMacroImported macroName = do let isFromPrelude = macroName `elem` preludeMacros isImportedDirectly <- any (\case SMacroImport macroImport -> macroName `elem` macroImport ^. imports - _ -> False) <$> - Sem.get + _notSMacroImport -> False) <$> + Eff.get pure $ isFromPrelude || isImportedDirectly ensureCompiledDependency :: forall fileExpanderEffs effs. - (Sem.Member (Sem.State ModuleInfo) effs, Sem.Members fileExpanderEffs effs) + (Eff.State ModuleInfo :> effs, fileExpanderEffs :>> effs) => FileExpander fileExpanderEffs -> Identifier - -> Sem.Sem effs () + -> Eff.Eff effs () ensureCompiledDependency expandFile dependencyName = do moduleInfo <- - Sem.gets (M.filter (\(moduleId', _) -> moduleId' == dependencyName)) + Eff.gets (M.filter (\(moduleId', _) -> moduleId' == dependencyName)) case head' $ M.toList moduleInfo of Just (dependencyFilePath, (_, transpiledOutput)) -> when (isNothing transpiledOutput) $ expandFile dependencyFilePath @@ -195,30 +193,30 @@ isCompoundExprWrapper = case hole zipper of Parse.Symbol _ "begin" -> True - _ -> False + _notSymbolBegin -> False in isCompoundExpr && not isCompoundExprWrapper -- | Fully expand a top-level expression. --- | Macro expansion is top-down: it proceeds top to bottom, outwards to inwards, --- | and left to right. Whenever a macro is successfully expanded to yield new --- | expressions in place of the macro call in question, the substitution is made --- | and macro expansion is repeated from the beginning. As new definitions, etc. --- | are found at the top level while the program tree is being traversed, they --- | will be added to the environment accessible to macros during expansion. +-- Macro expansion is top-down: it proceeds top to bottom, outwards to inwards, +-- and left to right. Whenever a macro is successfully expanded to yield new +-- expressions in place of the macro call in question, the substitution is made +-- and macro expansion is repeated from the beginning. As new definitions, etc. +-- are found at the top level while the program tree is being traversed, they +-- will be added to the environment accessible to macros during expansion. expandProgramExpr :: forall funAppExpanderEffs fileExpanderEffs effs innerEffs. - ( innerEffs ~ (Sem.State [SMStatement] : Effs.Restartable SM.Expression ': effs) - , Sem.Members '[ Sem.Error Error, Sem.State ModuleInfo, Sem.Reader Ghcid.Ghci, Sem.Reader FilePath] effs - , Sem.Members funAppExpanderEffs innerEffs - , Sem.Members fileExpanderEffs innerEffs + ( innerEffs ~ (Eff.State [SMStatement] ': Effs.Restartable SM.Expression ': effs) + , '[ Eff.Error Error, Eff.State ModuleInfo, Eff.Reader Ghcid.Ghci, Eff.Reader FilePath] :>> effs + , funAppExpanderEffs :>> innerEffs + , fileExpanderEffs :>> innerEffs ) => FunctionApplicationExpander funAppExpanderEffs -> FileExpander fileExpanderEffs -> SM.Expression - -> Sem.Sem effs SM.Expression + -> Eff.Eff effs SM.Expression expandProgramExpr expandFunApp expandFile programExpr = runRestartable @SM.Expression programExpr $ - Sem.evalState ([] :: [SMStatement]) . + Eff.evalState ([] :: [SMStatement]) . zipperTopDownTraverse (\zipper -> do when (isStatementFocused zipper) $ @@ -241,10 +239,10 @@ -- | Returns the full program expr (after the necessary substitution has been applied). replaceExpr :: - (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath] effs) + ('[ Eff.Error Error, Eff.Reader FilePath] :>> effs) => Zipper SM.Expression SM.Expression -> [SM.Expression] - -> Sem.Sem effs SM.Expression + -> Eff.Eff effs SM.Expression replaceExpr zipper newExprs = let programExpr = fromZipper zipper oldExpr = hole zipper @@ -267,20 +265,20 @@ then newExprs else pure x in Parse.SExpression ann' xs' - _ -> fatal "expandProgramExpr" "0001" + _notSExpression -> fatal "expandProgramExpr" "0001" newProgramExpr = fromZipper $ replaceHole newParentExpr oldParentExprZ in if newProgramExpr == programExpr then throwLoopError oldExpr newExprs else pure newProgramExpr throwLoopError :: - (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath] effs) + ('[ Eff.Error Error, Eff.Reader FilePath] :>> effs) => SM.Expression -> [SM.Expression] - -> Sem.Sem effs a + -> Eff.Eff effs a throwLoopError oldExpr newExprs = do - filePath <- Sem.ask - Sem.throw $ + filePath <- Eff.ask + Eff.throwError $ MacroError filePath oldExpr @@ -292,15 +290,15 @@ addStatementToMacroEnvironment :: forall fileExpanderEffs effs. - ( Sem.Members '[ Sem.Error Error, Sem.State ModuleInfo, Sem.Reader FilePath, Sem.State [SMStatement]] effs - , Sem.Members fileExpanderEffs effs + ( '[ Eff.Error Error, Eff.State ModuleInfo, Eff.Reader FilePath, Eff.State [SMStatement]] :>> effs + , fileExpanderEffs :>> effs ) => FileExpander fileExpanderEffs -> SM.Expression - -> Sem.Sem effs () + -> Eff.Eff effs () addStatementToMacroEnvironment expandFile newExpr = do - filePath <- Sem.ask - stmt <- Sem.runReader filePath $ withExprCtxt $ normalizeStatement newExpr + filePath <- Eff.ask + stmt <- Eff.runReader filePath $ withExprCtxt $ normalizeStatement newExpr let maybeDependencyName = case stmt of SRestrictedImport restrictedImport -> @@ -311,13 +309,13 @@ _ -> Nothing whenJust maybeDependencyName $ ensureCompiledDependency @fileExpanderEffs expandFile - Sem.modify @[SMStatement] (`snoc` stmt) + Eff.modify @[SMStatement] (`snoc` stmt) -- | If a function application is a macro call, expand it. handleFunctionApplication :: - (Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Sem.State ModuleInfo, Sem.Reader Ghcid.Ghci, Sem.Reader FilePath, Sem.State [SMStatement]] effs) + ('[ Eff.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Eff.State ModuleInfo, Eff.Reader Ghcid.Ghci, Eff.Reader FilePath, Eff.State [SMStatement]] :>> effs) => SM.Expression - -> Sem.Sem effs (Maybe [SM.Expression]) + -> Eff.Eff effs (Maybe [SM.Expression]) handleFunctionApplication fnApp@(Parse.SExpression ann (Parse.Symbol _ functionName:args)) = do shouldExpand <- isMacroCall $ T.pack functionName if shouldExpand @@ -329,9 +327,7 @@ handleFunctionApplication _ = pure Nothing isMacroCall :: - (Sem.Member (Sem.State [SMStatement]) effs) - => Identifier - -> Sem.Sem effs Bool + (Eff.State [SMStatement] :> effs) => Identifier -> Eff.Eff effs Bool isMacroCall function = do localDefs <- lookupMacroDefinitions function let isDefinedLocally = not $ null localDefs @@ -339,26 +335,26 @@ pure $ isImported || isDefinedLocally lookupMacroDefinitions :: - (Sem.Member (Sem.State [SMStatement]) effs) + (Eff.State [SMStatement] :> effs) => Identifier - -> Sem.Sem effs [MacroDefinition (Maybe SM.Expression)] + -> Eff.Eff effs [MacroDefinition (Maybe SM.Expression)] lookupMacroDefinitions identifier = filterMap (\stmt -> do macroDef <- stmt ^? _SMacroDefinition guard $ identifier == (macroDef ^. functionDefinition . name) pure macroDef) <$> - Sem.get + Eff.get hygenisizeMacroDefinition :: MacroDefinition ann -> MacroDefinition ann hygenisizeMacroDefinition = functionDefinition . name %~ hygenisizeMacroName insertImports :: - (Sem.Member (Sem.Error Error) effs) + (Eff.Error Error :> effs) => FilePath -> [SMStatement] -> [SMStatement] - -> Sem.Sem effs [SMStatement] + -> Eff.Eff effs [SMStatement] insertImports filePath newStmts program = case split (whenElt $ is _SModuleDeclaration) program of [preEnv, [moduleDecl@(SModuleDeclaration _ _)], postEnv] -> @@ -369,15 +365,16 @@ pure $ [moduleDecl] <> newStmts <> postEnv [[moduleDecl@(SModuleDeclaration _ _)]] -> pure $ [moduleDecl] <> newStmts _ -> - Sem.throw $ + Eff.throwError $ ParseError filePath "Axel files must contain exactly one module declaration!" mkMacroTypeSignature :: Identifier -> SMStatement -mkMacroTypeSignature = - SRawStatement Nothing . - (<> " :: [AST.Expression SM.SourceMetadata] -> GHCPrelude.IO [AST.Expression SM.SourceMetadata]") +mkMacroTypeSignature macroName = + SRawStatement Nothing $ + SM.raw (toHaskell (EIdentifier (Nothing :: Maybe SM.Expression) macroName)) <> + " :: [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata] -> AxelRuntime_GHCPrelude.IO [AxelRuntime_AST.Expression AxelRuntime_Sourcemap.SourceMetadata]" newtype ExpansionId = ExpansionId Text @@ -398,25 +395,42 @@ | not $ isPrelude filePath ] <> [ SQualifiedImport $ - QualifiedImport Nothing "Prelude" "GHCPrelude" (ImportAll Nothing) -- (in case `-XNoImplicitPrelude` is enabled) + QualifiedImport + Nothing + "Prelude" + "AxelRuntime_GHCPrelude" + (ImportAll Nothing) -- (in case `-XNoImplicitPrelude` is enabled) , SQualifiedImport $ - QualifiedImport Nothing "Axel.Parse.AST" "AST" (ImportAll Nothing) + QualifiedImport + Nothing + "Axel.Parse.AST" + "AxelRuntime_AST" + (ImportAll Nothing) + , SQualifiedImport $ + QualifiedImport + Nothing + "Axel.Sourcemap" + "AxelRuntime_Sourcemap" + (ImportAll Nothing) ] generateMacroProgram :: - (Sem.Members '[ Sem.Error Error, Effs.FileSystem, Sem.Reader ExpansionId, Sem.State [SMStatement]] effs) + ('[ Eff.Error Error, Effs.FileSystem, Eff.Reader ExpansionId, Eff.State [SMStatement]] :>> effs) => FilePath -> Identifier -> [SM.Expression] - -> Sem.Sem effs (SM.Output, SM.Output) + -> Eff.Eff effs (SM.Output, SM.Output) generateMacroProgram filePath' oldMacroName args = do - macroDefAndEnvModuleName <- Sem.asks mkMacroDefAndEnvModuleName - scaffoldModuleName <- Sem.asks mkScaffoldModuleName + macroDefAndEnvModuleName <- Eff.asks mkMacroDefAndEnvModuleName + scaffoldModuleName <- Eff.asks mkScaffoldModuleName let newMacroName = hygenisizeMacroName oldMacroName let mainFnName = "main_AXEL_AUTOGENERATED_FUNCTION_DEFINITION" let footer = [ mkMacroTypeSignature mainFnName - , SRawStatement Nothing $ mainFnName <> " = " <> newMacroName + , SRawStatement Nothing $ mainFnName <> " = " <> + SM.raw + (toHaskell + (EIdentifier (Nothing :: Maybe SM.Expression) newMacroName)) ] let (header, scaffold) = let mkModuleDecl = SModuleDeclaration Nothing @@ -437,14 +451,15 @@ mkList xs = mkFnApp (mkId "[") $ intersperse (mkRawExpr ",") xs <> [mkId "]"] -- This is VERY hacky, but it'll work without too much effort for now. in ( autogeneratedImports filePath' <> - [mkQualImport "Axel.Sourcemap" "SM"] + [mkQualImport "Axel.Sourcemap" "AxelRuntime_Sourcemap"] , mkModuleDecl scaffoldModuleName : autogeneratedImports filePath' <> [ mkQualImport macroDefAndEnvModuleName macroDefAndEnvModuleName - , mkQualImport "Axel.Sourcemap" "SM" - , mkTySig "main" $ mkFnApp (mkId "GHCPrelude.IO") [mkId "()"] + , mkQualImport "Axel.Sourcemap" "AxelRuntime_Sourcemap" + , mkTySig "main" $ + mkFnApp (mkId "AxelRuntime_GHCPrelude.IO") [mkId "()"] , mkFnDef "main" [] $ mkFnApp - (mkId "(GHCPrelude.>>=)") + (mkId "(AxelRuntime_GHCPrelude.>>=)") [ mkFnApp (mkQualId macroDefAndEnvModuleName @@ -456,17 +471,19 @@ args) ] , mkFnApp - (mkId "(GHCPrelude..)") - [ mkId "GHCPrelude.putStrLn" + (mkId "(AxelRuntime_GHCPrelude..)") + [ mkId "AxelRuntime_GHCPrelude.putStrLn" , mkFnApp - (mkId "(GHCPrelude..)") - [ mkId "GHCPrelude.unlines" - , mkFnApp (mkId "GHCPrelude.map") [mkId "AST.toAxel'"] + (mkId "(AxelRuntime_GHCPrelude..)") + [ mkId "AxelRuntime_GHCPrelude.unlines" + , mkFnApp + (mkId "AxelRuntime_GHCPrelude.map") + [mkId "AxelRuntime_AST.toAxel'"] ] ] ] ]) - prevStmts <- Sem.get @[SMStatement] + prevStmts <- Eff.get @[SMStatement] -- Mitigate the `::`/`=`-ordering problem (see the description of issue #65). let auxEnv = reverse . dropWhile (isn't _SMacroDefinition) . reverse $ prevStmts @@ -480,10 +497,7 @@ insertImports filePath' header $ replaceModuleDecl moduleDecl $ auxEnv <> footer pure $ finalizeProgram programStmts - pure $ - uncurry - ((,) `on` toHaskell . statementsToProgram) - (scaffold, macroDefAndEnv) + pure $ ((,) `on` toHaskell . statementsToProgram) scaffold macroDefAndEnv where replaceModuleDecl newModuleDecl stmts = if any (is _SModuleDeclaration) stmts @@ -500,7 +514,7 @@ getMacroNames = nub . map (^. functionDefinition . name) -- | Source metadata is lost. --- | Use only for logging and such where that doesn't matter. +-- Use only for logging and such where that doesn't matter. losslyReconstructMacroCall :: Identifier -> [SM.Expression] -> SM.Expression losslyReconstructMacroCall macroName args = Parse.SExpression @@ -509,23 +523,23 @@ withExpansionId :: SM.Expression - -> Sem.Sem (Sem.Reader ExpansionId ': effs) a - -> Sem.Sem effs a + -> Eff.Eff (Eff.Reader ExpansionId ': effs) a + -> Eff.Eff effs a withExpansionId originalCall x = let expansionId = showText $ abs $ hash originalCall -- We take the absolute value so that folder names don't start with dashes -- (it looks weird, even though it's not technically wrong). -- In theory, this allows for collisions, but the chances are negligibly small(?). - in Sem.runReader (ExpansionId expansionId) x + in Eff.runReader (ExpansionId expansionId) x expandMacroApplication :: - (Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Sem.Reader ExpansionId, Sem.Reader Ghcid.Ghci, Sem.Reader FilePath, Sem.State [SMStatement]] effs) + ('[ Eff.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Eff.Reader ExpansionId, Eff.Reader Ghcid.Ghci, Eff.Reader FilePath, Eff.State [SMStatement]] :>> effs) => SourceMetadata -> Identifier -> [SM.Expression] - -> Sem.Sem effs [SM.Expression] + -> Eff.Eff effs [SM.Expression] expandMacroApplication originalAnn macroName args = do logStrLn $ "Expanding: " <> toAxel (losslyReconstructMacroCall macroName args) - filePath' <- Sem.ask @FilePath + filePath' <- Eff.ask @FilePath macroProgram <- generateMacroProgram filePath' macroName args (tempFilePath, newSource) <- uncurry (evalMacro originalAnn macroName args) macroProgram @@ -538,16 +552,16 @@ evalMacro :: forall effs. - (Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Sem.Reader Ghcid.Ghci, Sem.Reader FilePath, Sem.Reader ExpansionId] effs) + ('[ Eff.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Eff.Reader Ghcid.Ghci, Eff.Reader FilePath, Eff.Reader ExpansionId] :>> effs) => SourceMetadata -> Identifier -> [SM.Expression] -> SM.Output -> SM.Output - -> Sem.Sem effs (FilePath, Text) + -> Eff.Eff effs (FilePath, Text) evalMacro originalCallAnn macroName args scaffoldProgram macroDefAndEnvProgram = do - macroDefAndEnvModuleName <- Sem.asks mkMacroDefAndEnvModuleName - scaffoldModuleName <- Sem.asks mkScaffoldModuleName + macroDefAndEnvModuleName <- Eff.asks mkMacroDefAndEnvModuleName + scaffoldModuleName <- Eff.asks mkScaffoldModuleName tempDir <- getTempDirectory let macroDefAndEnvFileName = tempDir FilePath macroDefAndEnvModuleName <.> "hs" @@ -563,7 +577,7 @@ , ( macroDefAndEnvFileName , (macroDefAndEnvModuleName, Just macroDefAndEnvProgram)) ] - ghci <- Sem.ask @Ghcid.Ghci + ghci <- Eff.ask @Ghcid.Ghci loadResult <- Ghci.addFiles ghci [scaffoldFileName, macroDefAndEnvFileName] if any ("Ok, " `T.isPrefixOf`) loadResult then do @@ -585,13 +599,13 @@ macroDefAndEnv = SM.raw macroDefAndEnvProgram scaffold = SM.raw scaffoldProgram getTempDirectory = do - ExpansionId expansionId <- Sem.ask @ExpansionId + ExpansionId expansionId <- Eff.ask @ExpansionId let dirName = FilePath "axelTemp" FilePath expansionId FS.createDirectoryIfMissing True dirName pure dirName throwMacroError msg = do - originalFilePath <- Sem.ask @FilePath - Sem.throw $ + originalFilePath <- Eff.ask @FilePath + Eff.throwError $ MacroError originalFilePath (losslyReconstructMacroCall macroName args) @@ -625,7 +639,4 @@ "." ] where - locationHint = - case originalAnn of - Just x -> renderSourcePosition x - Nothing -> "" + locationHint = maybe "" renderSourcePosition originalAnn diff --git a/src/Axel/Normalize.hs b/src/Axel/Normalize.hs --- a/src/Axel/Normalize.hs +++ b/src/Axel/Normalize.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE GADTs #-} module Axel.Normalize where @@ -9,8 +8,8 @@ ( CaseBlock(CaseBlock) , DataDeclaration(DataDeclaration) , Expression(ECaseBlock, EEmptySExpression, EFunctionApplication, - EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression, - ERecordDefinition, ERecordType) + EIdentifier, ELambda, ELetBlock, ELiteral, EPatternBinding, + ERawExpression, ERecordDefinition, ERecordType) , FunctionApplication(FunctionApplication) , FunctionDefinition(FunctionDefinition) , Identifier @@ -22,12 +21,12 @@ , MacroDefinition(MacroDefinition) , MacroImport(MacroImport) , NewtypeDeclaration(NewtypeDeclaration) + , PatternBinding(PatternBinding) , Pragma(Pragma) , QualifiedImport(QualifiedImport) , RecordDefinition(RecordDefinition) , RecordType(RecordType) , RestrictedImport(RestrictedImport) - , SMExpression , SMStatement , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition, SMacroImport, SModuleDeclaration, SNewtypeDeclaration, SPragma, @@ -41,6 +40,7 @@ , TypeclassDefinition(TypeclassDefinition) , TypeclassInstance(TypeclassInstance) ) +import Axel.Eff ((:>>)) import Axel.Eff.Error (Error(NormalizeError), renderError, unsafeRunError) import Axel.Parse (unhygenisizeIdentifier) import qualified Axel.Parse.AST as Parse @@ -51,35 +51,36 @@ import qualified Data.Text as T -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.Reader as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.Reader.Static as Eff type ExprCtxt = [SM.Expression] pushCtxt :: - (Sem.Member (Sem.Reader [SM.Expression]) effs) + (Eff.Reader [SM.Expression] :> effs) => SM.Expression - -> Sem.Sem effs a - -> Sem.Sem effs a -pushCtxt newCtxt = Sem.local (newCtxt :) + -> Eff.Eff effs a + -> Eff.Eff effs a +pushCtxt newCtxt = Eff.local (newCtxt :) -withExprCtxt :: Sem.Sem (Sem.Reader [SM.Expression] ': effs) a -> Sem.Sem effs a -withExprCtxt = Sem.runReader [] +withExprCtxt :: Eff.Eff (Eff.Reader [SM.Expression] ': effs) a -> Eff.Eff effs a +withExprCtxt = Eff.runReader [] throwNormalizeError :: - (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath, Sem.Reader ExprCtxt] effs) + ('[ Eff.Error Error, Eff.Reader FilePath, Eff.Reader ExprCtxt] :>> effs) => Text - -> Sem.Sem effs a + -> Eff.Eff effs a throwNormalizeError msg = do - filePath <- Sem.ask @FilePath - exprCtxt <- Sem.ask @ExprCtxt - Sem.throw $ NormalizeError filePath msg exprCtxt + filePath <- Eff.ask @FilePath + exprCtxt <- Eff.ask @ExprCtxt + Eff.throwError $ NormalizeError filePath msg exprCtxt normalizeExpression :: - (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath, Sem.Reader ExprCtxt] effs) + ('[ Eff.Error Error, Eff.Reader FilePath, Eff.Reader ExprCtxt] :>> effs) => SM.Expression - -> Sem.Sem effs (Expression (Maybe SM.Expression)) + -> Eff.Eff effs (Expression (Maybe SM.Expression)) normalizeExpression expr@(Parse.LiteralChar _ char) = pure $ ELiteral (LChar (Just expr) char) normalizeExpression expr@(Parse.LiteralFloat _ float) = @@ -113,9 +114,16 @@ _ -> throwNormalizeError "`case` takes an expression followed by `case` clauses." + "@" -> + case args of + [name, pattern'] -> + EPatternBinding <$> + (PatternBinding (Just expr) <$> normalizeExpression name <*> + normalizeExpression pattern') + _ -> throwNormalizeError "`@` takes: 1) a name and 2) a pattern." "\\" -> case args of - [Parse.SExpression _ args', body] -> + [Parse.SExpression _ (Parse.Symbol _ "list":args'), body] -> let normalizedArguments = traverse normalizeExpression args' in ELambda <$> (Lambda (Just expr) <$> normalizedArguments <*> @@ -125,7 +133,7 @@ "`\\` takes exactly two arguments: 1) an argument list and 2) a body." "let" -> case args of - [Parse.SExpression _ bindings, body] -> + [Parse.SExpression _ (Parse.Symbol _ "list":bindings), body] -> let normalizedBindings = traverse (\case @@ -198,13 +206,13 @@ pure $ EIdentifier (Just expr) (T.pack symbol) normalizeFunctionDefinition :: - (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath, Sem.Reader ExprCtxt] effs) + ('[ Eff.Error Error, Eff.Reader FilePath, Eff.Reader ExprCtxt] :>> effs) => SM.Expression -> Identifier -> [SM.Expression] -> SM.Expression -> [SM.Expression] - -> Sem.Sem effs (FunctionDefinition (Maybe SM.Expression)) + -> Eff.Eff effs (FunctionDefinition (Maybe SM.Expression)) normalizeFunctionDefinition expr fnName arguments body whereDefs = FunctionDefinition (Just expr) fnName <$> traverse normalizeExpression arguments <*> @@ -220,24 +228,10 @@ "Each `where` binding must be either a function definition or a type signature!") whereDefs -normalizeConstraints :: - (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath, Sem.Reader ExprCtxt] effs) - => SM.Expression - -> Sem.Sem effs [SMExpression] -normalizeConstraints constraints = - normalizeExpression constraints >>= \case - EEmptySExpression _ -> pure [] - EFunctionApplication (FunctionApplication _ constraintsHead constraintsRest) -> - pure $ constraintsHead : constraintsRest - _ -> - pushCtxt constraints $ - throwNormalizeError - "Constraint lists must only contain type constructors!" - normalizeStatement :: - (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath, Sem.Reader ExprCtxt] effs) + ('[ Eff.Error Error, Eff.Reader FilePath, Eff.Reader ExprCtxt] :>> effs) => SM.Expression - -> Sem.Sem effs SMStatement + -> Eff.Eff effs SMStatement normalizeStatement expr@(Parse.SExpression _ items) = pushCtxt expr $ case items of @@ -245,10 +239,10 @@ case unhygenisizeIdentifier special of "::" -> case args of - [Parse.Symbol _ fnName, constraints, typeDef] -> + [Parse.Symbol _ fnName, Parse.SExpression _ (Parse.Symbol _ "list":constraints), typeDef] -> STypeSignature <$> (TypeSignature (Just expr) (T.pack fnName) <$> - normalizeConstraints constraints <*> + traverse normalizeExpression constraints <*> normalizeExpression typeDef) _ -> throwNormalizeError @@ -279,17 +273,8 @@ in STopLevel . TopLevel (Just expr) <$> normalizedStmts "class" -> case args of - classConstraints:className:sigs -> - let normalizedConstraints = - normalizeExpression classConstraints >>= \case - EEmptySExpression _ -> pure [] - EFunctionApplication (FunctionApplication _ constraintsHead constraintsRest) -> - pure $ constraintsHead : constraintsRest - _ -> - pushCtxt classConstraints $ - throwNormalizeError - "A `class` constraint list must only contain type constructors!" - normalizedSigs = + Parse.SExpression _ (Parse.Symbol _ "list":classConstraints):className:sigs -> + let normalizedSigs = traverse (\x -> normalizeStatement x >>= \case @@ -302,55 +287,60 @@ in STypeclassDefinition <$> (TypeclassDefinition (Just expr) <$> normalizeExpression className <*> - normalizedConstraints <*> + traverse normalizeExpression classConstraints <*> normalizedSigs) _ -> throwNormalizeError "`class` takes a constraint list, a type constructor, and type signatures!" "data" -> case args of - typeDef:constructors -> - normalizeExpression typeDef >>= \case - EFunctionApplication typeConstructor -> - SDataDeclaration <$> - (DataDeclaration - (Just expr) - (TypeConstructor (Just expr) typeConstructor) <$> - traverse normalizeExpression constructors) - EIdentifier _ properType -> - SDataDeclaration <$> - (DataDeclaration - (Just expr) - (ProperType (Just expr) properType) <$> - traverse normalizeExpression constructors) - _ -> - pushCtxt typeDef $ - throwNormalizeError "Invalid type constructor!" + typeDef:rest -> + let (constructors, derivedConstraints) = + case last rest of + Parse.SExpression _ (Parse.Symbol _ "list":xs) -> + (init rest, xs) + _ -> (rest, []) + in SDataDeclaration <$> + (DataDeclaration (Just expr) <$> + (normalizeExpression typeDef >>= \case + EFunctionApplication typeConstructor -> + pure $ TypeConstructor (Just expr) typeConstructor + EIdentifier _ properType -> + pure $ ProperType (Just expr) properType + _ -> + pushCtxt typeDef $ + throwNormalizeError "Invalid type constructor!") <*> + traverse normalizeExpression constructors <*> + traverse normalizeExpression derivedConstraints) _ -> throwNormalizeError - "`data` takes a type constructor followed by type constructors!" + "`data` takes a type constructor followed by type constructors, optionally followed by a list of constraints to derive!" "newtype" -> case args of - [typeDef, wrappedType] -> - normalizeExpression typeDef >>= \case - EFunctionApplication typeConstructor -> - SNewtypeDeclaration <$> - (NewtypeDeclaration - (Just expr) - (TypeConstructor (Just expr) typeConstructor) <$> - normalizeExpression wrappedType) - EIdentifier _ properType -> - SNewtypeDeclaration <$> - (NewtypeDeclaration - (Just expr) - (ProperType (Just expr) properType) <$> - normalizeExpression wrappedType) - _ -> - pushCtxt typeDef $ - throwNormalizeError "Invalid type constructor!" + typeDef:wrappedType:rest -> + let derivedConstraints = + case rest of + [] -> pure [] + [Parse.SExpression _ (Parse.Symbol _ "list":xs)] -> + traverse normalizeExpression xs + _ -> + throwNormalizeError + "Invalid list of constraints to derive!" + in SNewtypeDeclaration <$> + (NewtypeDeclaration (Just expr) <$> + (normalizeExpression typeDef >>= \case + EFunctionApplication typeConstructor -> + pure $ TypeConstructor (Just expr) typeConstructor + EIdentifier _ properType -> + pure $ ProperType (Just expr) properType + _ -> + pushCtxt typeDef $ + throwNormalizeError "Invalid type constructor!") <*> + normalizeExpression wrappedType <*> + derivedConstraints) _ -> throwNormalizeError - "`newtype` takes exactly two arguments: 1) a type constructor and 2) a type." + "`newtype` takes two or three arguments: 1) a type constructor, 2) a type, and optionally 3) a list of constraints to derive!" "import" -> case args of [Parse.Symbol _ moduleName, importSpec] -> @@ -363,7 +353,7 @@ "importm" -> case args of [Parse.Symbol _ moduleName, macroImportSpec] -> - SMacroImport . MacroImport (Just expr) (T.pack $ moduleName) <$> + SMacroImport . MacroImport (Just expr) (T.pack moduleName) <$> normalizeMacroImportSpec macroImportSpec _ -> throwNormalizeError @@ -379,7 +369,7 @@ "`importq` takes exactly three arguments: 1) a module name, 2) a module name, and 3) an import specification." "instance" -> case args of - instanceConstraints:instanceName:defs -> + Parse.SExpression _ (Parse.Symbol _ "list":instanceConstraints):instanceName:defs -> let normalizedDefs = traverse (\x -> @@ -393,7 +383,7 @@ in STypeclassInstance <$> (TypeclassInstance (Just expr) <$> normalizeExpression instanceName <*> - normalizeConstraints instanceConstraints <*> + traverse normalizeExpression instanceConstraints <*> normalizedDefs) _ -> throwNormalizeError @@ -407,12 +397,12 @@ "`pragma` takes exactly one argument: a string literal." "=macro" -> case args of - Parse.Symbol _ macroName:Parse.SExpression _ arguments:body:whereBindings -> + Parse.Symbol _ macroName:argument:body:whereBindings -> SMacroDefinition . MacroDefinition (Just expr) <$> normalizeFunctionDefinition expr (T.pack macroName) - arguments + [argument] body whereBindings _ -> @@ -454,7 +444,7 @@ where normalizeMacroImportSpec importSpec = case importSpec of - Parse.SExpression _ macroImportList -> + Parse.SExpression _ (Parse.Symbol _ "list":macroImportList) -> traverse (\case Parse.Symbol _ import' -> pure $ T.pack import' @@ -469,7 +459,8 @@ normalizeImportSpec importSpec = case importSpec of Parse.Symbol _ "all" -> pure $ ImportAll (Just expr) - Parse.SExpression _ importList -> normalizeImportList importList + Parse.SExpression _ (Parse.Symbol _ "list":importList) -> + normalizeImportList importList x -> pushCtxt x $ throwNormalizeError @@ -501,9 +492,9 @@ pushCtxt expr $ throwNormalizeError "Invalid top-level form!" unsafeNormalize :: - (SM.Expression -> Sem.Sem '[ Sem.Reader ExprCtxt, Sem.Reader FilePath, Sem.Error Error] a) + (SM.Expression -> Eff.Eff '[ Eff.Reader ExprCtxt, Eff.Reader FilePath, Eff.Error Error] a) -> SM.Expression -> a unsafeNormalize f = - Sem.run . - unsafeRunError renderError . Sem.runReader (FilePath "") . withExprCtxt . f + Eff.runPureEff . + unsafeRunError renderError . Eff.runReader (FilePath "") . withExprCtxt . f diff --git a/src/Axel/Parse.hs b/src/Axel/Parse.hs --- a/src/Axel/Parse.hs +++ b/src/Axel/Parse.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} - module Axel.Parse where import Axel.Prelude @@ -37,8 +35,9 @@ import qualified Data.Text as T import Data.Void (Void) -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P @@ -75,7 +74,8 @@ eol = void P.eol <|> P.eof ignored :: Parser () -ignored = P.skipMany $ P.try comment <|> void P.spaceChar +ignored = + P.skipMany $ P.try singleLineComment <|> multiLineComment <|> void P.spaceChar literalChar :: Parser SM.Expression literalChar = ann LiteralChar (P.string "#\\" *> P.charLiteral) @@ -131,11 +131,15 @@ unquotedExpression :: Parser SM.Expression unquotedExpression = parseReadMacro "~" "unquote" -comment :: Parser () -comment = +singleLineComment :: Parser () +singleLineComment = P.try (P.string "--" *> eol) <|> void (P.string "-- " *> P.manyTill (void P.anySingle) eol) +multiLineComment :: Parser () +multiLineComment = + void $ P.try (P.string "{-") *> P.manyTill (void P.anySingle) (P.string "-}") + expression :: Parser SM.Expression expression = P.try literalFloat <|> P.try literalInt <|> sExpression <|> infixSExpression <|> @@ -157,7 +161,7 @@ expandQuasiquote (SExpression ann' xs) = SExpression ann' - [ Symbol ann' "AST.SExpression" + [ Symbol ann' "AxelRuntime_AST.SExpression" , quoteSourceMetadata ann' , SExpression ann' @@ -172,30 +176,31 @@ expandQuasiquoteInList :: SM.Expression -> SM.Expression expandQuasiquoteInList (SExpression _ [Symbol _ "unquoteSplicing", expr]) = let ann' = getAnn expr - in SExpression ann' [Symbol ann' "AST.toExpressionList", expr] + in SExpression ann' [Symbol ann' "AxelRuntime_AST.toExpressionList", expr] expandQuasiquoteInList expr = let ann' = getAnn expr in SExpression ann' [Symbol ann' "list", expandQuasiquote expr] parseMultiple' :: - (Sem.Member (Sem.Error Error) effs) + (Eff.Error Error :> effs) => ([SM.Expression] -> [SM.Expression]) -> Maybe FilePath -> Text - -> Sem.Sem effs [SM.Expression] + -> Eff.Eff effs [SM.Expression] parseMultiple' postProcess maybeFilePath input = either throwErr (pure . postProcess) $ P.parse program (T.unpack $ op FilePath filePath) input where filePath = fromMaybe (FilePath "") maybeFilePath program = P.some (ignored *> expression <* ignored) <* P.eof - throwErr = Sem.throw . ParseError filePath . T.pack . P.errorBundlePretty + throwErr = + Eff.throwError . ParseError filePath . T.pack . P.errorBundlePretty parseMultiple :: - (Sem.Member (Sem.Error Error) effs) + (Eff.Error Error :> effs) => Maybe FilePath -> Text - -> Sem.Sem effs [SM.Expression] + -> Eff.Eff effs [SM.Expression] parseMultiple = parseMultiple' expandQuasiquotes where expandQuasiquotes = @@ -206,10 +211,10 @@ x -> [x]) parseSource :: - (Sem.Member (Sem.Error Error) effs) + (Eff.Error Error :> effs) => Maybe FilePath -> Text - -> Sem.Sem effs SM.Expression + -> Eff.Eff effs SM.Expression parseSource filePath input = wrapCompoundExpressions <$> parseMultiple filePath input diff --git a/src/Axel/Parse/AST.hs b/src/Axel/Parse/AST.hs --- a/src/Axel/Parse/AST.hs +++ b/src/Axel/Parse/AST.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +-- | The definition of and utilities for Axel's Abstract Syntax Tree (AST). module Axel.Parse.AST where import Axel.Prelude @@ -12,7 +11,6 @@ , ZipperRecursive(zipperBottomUpTraverse, zipperTopDownTraverse) , bottomUpFmap ) -import Axel.Utils.Text (handleCharEscapes) import Axel.Utils.Zipper (unsafeDown, unsafeUp) import Control.Lens ((<|)) @@ -30,7 +28,6 @@ ) import Data.Hashable (Hashable) import Data.MonoTraversable (oconcatMap) -import Data.Semigroup ((<>)) import qualified Data.Text as T import GHC.Generics (Generic) @@ -40,13 +37,14 @@ -- (Maybe all macros have the argument automatically `fromFix`-ed to make consumption simpler?) -- NOTE We're using `String` instead of `Text` so that we don't have to rely -- on `Axel.Prelude` in user-facing code. +-- | An Axel form's AST. All Axel code is parsed into nested applications of this data structure. data Expression ann - = LiteralChar ann Char - | LiteralFloat ann Float - | LiteralInt ann Int - | LiteralString ann String - | SExpression ann [Expression ann] - | Symbol ann String + = LiteralChar ann Char -- ^ A character literal, e.g. @#\a@. + | LiteralInt ann Int -- ^ An integer literal, e.g. @123@. + | LiteralFloat ann Float -- ^ A floating point literal, e.g. @1.23@. + | LiteralString ann String -- ^ A string literal, e.g @"test"@. + | SExpression ann [Expression ann] -- ^ A parenthesized list of expressions, e.g. @(foo a b c)@. + | Symbol ann String -- ^ An identifier, e.g. @foo@. deriving (Eq, Data, Functor, Generic, Show) makePrisms ''Expression @@ -54,6 +52,7 @@ instance (Hashable ann) => Hashable (Expression ann) -- TODO Derive this automatically. +-- | Get the source metadata from an 'Expression'. getAnn :: Expression ann -> ann getAnn (LiteralChar ann _) = ann getAnn (LiteralFloat ann _) = ann @@ -108,6 +107,9 @@ Symbol _ _ -> pure recurse z' +-- | Modify an 'Expression' tree bottom-up, replacing each node with multiple 'Expression's. +-- This works with every expression in an Axel program, including top-level statements. +-- Also see the methods in 'Axel.Utils.Recursion'. bottomUpFmapSplicing :: (Data ann) => (Expression ann -> [Expression ann]) @@ -122,7 +124,7 @@ toAxel (LiteralChar _ x) = "#\\" <> T.singleton x toAxel (LiteralFloat _ x) = showText x toAxel (LiteralInt _ x) = showText x -toAxel (LiteralString _ xs) = "\"" <> handleCharEscapes (T.pack xs) <> "\"" +toAxel (LiteralString _ xs) = showText xs toAxel (SExpression _ (Symbol _ "applyInfix":xs)) = "{" <> T.unwords (map toAxel xs) <> "}" toAxel (SExpression _ (Symbol _ "list":xs)) = @@ -136,37 +138,58 @@ -- NOTE We're using `String` instead of `Text` so that we don't have to rely -- on `Axel.Prelude` in user-facing code. +-- | NOTE This is for internal use; you likely don't need to use this directly. +-- +-- Convert an 'Expression' to valid Axel source. toAxel' :: Expression ann -> String toAxel' = T.unpack . toAxel -- TODO Derive this with Template Haskell (it's currently very brittle) -quoteExpression :: (ann -> Expression ann) -> Expression ann -> Expression ann +-- | Quote an 'Expression' (this is what the @quote@ special form uses under-the-hood). +quoteExpression :: + (ann -> Expression ann) -- ^ Process the source metadata attached to the expression. + -- The returned 'Expression', when rendered via 'toAxel'', + -- must evaluate to a valid Axel expression. + -> Expression ann -- ^ The expression to quote. + -> Expression ann quoteExpression quoteAnn (LiteralChar ann x) = SExpression ann - [Symbol ann "AST.LiteralChar", quoteAnn ann, LiteralChar ann x] + [Symbol ann "AxelRuntime_AST.LiteralChar", quoteAnn ann, LiteralChar ann x] quoteExpression quoteAnn (LiteralFloat ann x) = SExpression ann - [Symbol ann "AST.LiteralFloat", quoteAnn ann, LiteralFloat ann x] + [ Symbol ann "AxelRuntime_AST.LiteralFloat" + , quoteAnn ann + , LiteralFloat ann x + ] quoteExpression quoteAnn (LiteralInt ann x) = - SExpression ann [Symbol ann "AST.LiteralInt", quoteAnn ann, LiteralInt ann x] + SExpression + ann + [Symbol ann "AxelRuntime_AST.LiteralInt", quoteAnn ann, LiteralInt ann x] quoteExpression quoteAnn (LiteralString ann x) = SExpression ann - [Symbol ann "AST.LiteralString", quoteAnn ann, LiteralString ann x] + [ Symbol ann "AxelRuntime_AST.LiteralString" + , quoteAnn ann + , LiteralString ann x + ] quoteExpression quoteAnn (SExpression ann xs) = SExpression ann - [ Symbol ann "AST.SExpression" + [ Symbol ann "AxelRuntime_AST.SExpression" , quoteAnn ann , SExpression ann (Symbol ann "list" : map (quoteExpression quoteAnn) xs) ] quoteExpression quoteAnn (Symbol ann x) = - SExpression ann [Symbol ann "AST.Symbol", quoteAnn ann, LiteralString ann x] + SExpression + ann + [Symbol ann "AxelRuntime_AST.Symbol", quoteAnn ann, LiteralString ann x] --- | This allows splice-unquoting of both `[Expression]`s and `SExpression`s, --- | without requiring special syntax for each. +-- | NOTE This is for internal use; you likely don't need to use this directly. +-- +-- This allows splice-unquoting of both `[Expression]`s and `SExpression`s, +-- without requiring special syntax for each. class ToExpressionList a where type Annotation a toExpressionList :: a -> [Expression (Annotation a)] @@ -176,9 +199,11 @@ toExpressionList :: [Expression ann] -> [Expression ann] toExpressionList = id --- | Because we do not have a way to statically ensure an `SExpression` is passed --- | (and not another one of `Expression`'s constructors instead), --- | we will error at compile-time if a macro attempts to splice-unquote inappropriately. +-- | NOTE This is for internal use; you likely don't need to use this directly. +-- +-- Because we do not have a way to statically ensure an `SExpression` is passed +-- (and not another one of `Expression`'s constructors instead), +-- we will error at compile-time if a macro attempts to splice-unquote inappropriately. instance ToExpressionList (Expression ann) where type Annotation (Expression ann) = ann toExpressionList :: Expression ann -> [Expression ann] diff --git a/src/Axel/Parse/Args.hs b/src/Axel/Parse/Args.hs --- a/src/Axel/Parse/Args.hs +++ b/src/Axel/Parse/Args.hs @@ -1,16 +1,16 @@ module Axel.Parse.Args where import Axel -import qualified Prelude as GHCPrelude -import qualified Axel.Parse.AST as AST +import qualified Prelude as AxelRuntime_GHCPrelude +import qualified Axel.Parse.AST as AxelRuntime_AST +import qualified Axel.Sourcemap as AxelRuntime_Sourcemap import Axel.Prelude import Control.Applicative((<**>)) import Data.Foldable(asum) -import Data.Semigroup((<>)) import qualified Data.Text as T import Options.Applicative(Parser,ParserInfo,argument,command,fullDesc,helper,hsubparser,info,metavar,progDesc,str) -data FileCommand = ConvertFile FilePath|RunFile FilePath|FormatFile FilePath -data ProjectCommand = ConvertProject|FormatProject|RunProject -data Command = FileCommand FileCommand|ProjectCommand ProjectCommand|Version +data FileCommand = ConvertFile FilePath|RunFile FilePath|FormatFile FilePath deriving () +data ProjectCommand = ConvertProject|FormatProject|RunProject deriving () +data Command = FileCommand FileCommand|ProjectCommand ProjectCommand|Version deriving () experimental :: () => ((->) String String) experimental = ((<>) "(EXPERIMENTAL) ") command' :: () => ((->) String ((->) (ParserInfo a) (Parser a))) diff --git a/src/Axel/Pretty.hs b/src/Axel/Pretty.hs --- a/src/Axel/Pretty.hs +++ b/src/Axel/Pretty.hs @@ -7,17 +7,15 @@ import qualified Axel.Sourcemap as SM import Axel.Utils.Foldable (mapWithPrev) import Axel.Utils.Recursion (bottomUpFmap) -import Axel.Utils.Text (handleCharEscapes) import Control.Lens (ala, under) -import Data.Maybe (fromMaybe) -import Data.Semigroup (Max(Max), (<>)) +import Data.Semigroup (Max(Max)) import qualified Data.Text as T import Data.Text.Lens (unpacked) -import qualified Data.Text.Prettyprint.Doc as P -import Data.Text.Prettyprint.Doc ((<+>)) -import qualified Data.Text.Prettyprint.Doc.Render.Text as P +import qualified Prettyprinter as P +import Prettyprinter ((<+>)) +import qualified Prettyprinter.Render.Text as P render :: P.Doc a -> Text render = P.renderStrict . P.layoutSmart (P.LayoutOptions P.Unbounded) @@ -28,63 +26,63 @@ columnWidth :: Text -> Int columnWidth = ala Max foldMap . map T.length . T.lines -sexp :: [P.Doc a] -> P.Doc a -sexp [] = mempty -sexp [x] = x -sexp (x:xs) = +sexp :: Bool -> [P.Doc a] -> P.Doc a +sexp _ [] = mempty +sexp _ [x] = x +sexp canBalance (x:xs) = let align cons = x `cons` xs oneLiner = align (\y ys -> y <+> P.hsep ys) balanced = align (\y ys -> y <+> P.align (P.vsep ys)) multiLiner = align (\y ys -> P.align (P.vsep (y : ys))) shortEnough doc = columnWidth (render doc) <= maximumExpressionLength in if | shortEnough oneLiner -> oneLiner - | shortEnough balanced -> balanced + | canBalance && shortEnough balanced -> balanced | otherwise -> multiLiner privilegedFormToAxelPretty :: [Expression ann] -> P.Doc a privilegedFormToAxelPretty (Symbol _ "data":name:rest) = - "data" <+> sexp (toAxelPretty name : map toAxelPretty rest) + "data" <+> sexp True (toAxelPretty name : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "def":name:tySig:rest) = "def" <+> P.align (P.vsep - [ (toAxelPretty name <+> toAxelPretty tySig) - , sexp (map toAxelPretty rest) + [ toAxelPretty name <+> toAxelPretty tySig + , sexp True (map toAxelPretty rest) ]) privilegedFormToAxelPretty (Symbol _ "defmacro":name:rest) = - "defmacro" <+> sexp (toAxelPretty name : map toAxelPretty rest) + "defmacro" <+> sexp True (toAxelPretty name : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "::":name:rest) = - "::" <+> sexp (toAxelPretty name : map toAxelPretty rest) + "::" <+> sexp True (toAxelPretty name : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "=":name:args:rest) = "=" <+> - sexp ((toAxelPretty name <+> toAxelPretty args) : map toAxelPretty rest) + sexp True ((toAxelPretty name <+> toAxelPretty args) : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "=macro":name:args:rest) = "=macro" <+> - sexp ((toAxelPretty name <+> toAxelPretty args) : map toAxelPretty rest) + sexp True ((toAxelPretty name <+> toAxelPretty args) : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "let":bindings:rest) = - "let" <+> sexp (toAxelPretty bindings : map toAxelPretty rest) + "let" <+> sexp True (toAxelPretty bindings : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "if":bindings:rest) = - "if" <+> sexp (toAxelPretty bindings : map toAxelPretty rest) + "if" <+> sexp True (toAxelPretty bindings : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "case":bindings:rest) = - "case" <+> sexp (toAxelPretty bindings : map toAxelPretty rest) + "case" <+> sexp True (toAxelPretty bindings : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "import":name:rest) = - "import" <+> sexp (toAxelPretty name : map toAxelPretty rest) + "import" <+> sexp True (toAxelPretty name : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "importq":name:rest) = - "importq" <+> sexp (toAxelPretty name : map toAxelPretty rest) + "importq" <+> sexp True (toAxelPretty name : map toAxelPretty rest) privilegedFormToAxelPretty (Symbol _ "importm":name:rest) = - "importm" <+> sexp (toAxelPretty name : map toAxelPretty rest) -privilegedFormToAxelPretty xs = sexp $ map toAxelPretty xs + "importm" <+> sexp True (toAxelPretty name : map toAxelPretty rest) +privilegedFormToAxelPretty xs = sexp True $ map toAxelPretty xs toAxelPretty :: Expression ann -> P.Doc a toAxelPretty (LiteralChar _ x) = "#\\" <> P.pretty x toAxelPretty (LiteralFloat _ x) = P.pretty x toAxelPretty (LiteralInt _ x) = P.pretty x toAxelPretty (LiteralString _ x) = - P.dquotes $ P.pretty (under unpacked handleCharEscapes x) + P.dquotes $ P.pretty (under unpacked showText x) toAxelPretty (SExpression _ (Symbol _ "applyInfix":xs)) = - P.braces $ sexp (map toAxelPretty xs) + P.braces $ sexp True (map toAxelPretty xs) toAxelPretty (SExpression _ (Symbol _ "list":xs)) = - P.brackets $ sexp (map toAxelPretty xs) + P.brackets $ sexp False (map toAxelPretty xs) toAxelPretty (SExpression _ [Symbol _ "quote", x]) = "\'" <> toAxelPretty x toAxelPretty (SExpression _ [Symbol _ "quasiquote", x]) = "`" <> toAxelPretty x toAxelPretty (SExpression _ [Symbol _ "unquote", x]) = "~" <> toAxelPretty x @@ -99,7 +97,7 @@ let isImport (SExpression _ (Symbol _ id':_)) = id' `elem` ["import", "importq", "importm"] isImport _ = False - needsSpacing = not $ isImport x && fromMaybe False (isImport <$> prev) + needsSpacing = not $ isImport x && maybe False isImport prev maybeSpacer = if needsSpacing then P.line diff --git a/src/Axel/Sourcemap.hs b/src/Axel/Sourcemap.hs --- a/src/Axel/Sourcemap.hs +++ b/src/Axel/Sourcemap.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} module Axel.Sourcemap where @@ -13,6 +11,7 @@ ( Expression(LiteralInt, LiteralString, SExpression, Symbol) , quoteExpression ) +import Axel.Utils.List (unsafeHead) import Axel.Utils.Text (Renderer) import Axel.Utils.Tuple (Annotated, annotate, annotation, unannotate) @@ -28,10 +27,10 @@ import Data.MonoTraversable (oconcatMap, ofor_) import qualified Data.Text as T -import GHC.Generics (Generic) +import qualified Effectful as Eff +import qualified Effectful.State.Static.Local as Eff -import qualified Polysemy as Sem -import qualified Polysemy.State as Sem +import GHC.Generics (Generic) data Position = Position @@ -98,21 +97,35 @@ | SingleQuotes | SquareBrackets +openBracket :: Bracket -> Char +openBracket CurlyBraces = '{' +openBracket DoubleQuotes = '"' +openBracket Parentheses = '(' +openBracket SingleQuotes = '\'' +openBracket SquareBrackets = '[' + +closeBracket :: Bracket -> Char +closeBracket CurlyBraces = '}' +closeBracket DoubleQuotes = '"' +closeBracket Parentheses = ')' +closeBracket SingleQuotes = '\'' +closeBracket SquareBrackets = ']' + +tryRemoveBrackets :: Bracket -> Text -> Text +tryRemoveBrackets bracket text = + if T.length text >= 2 && + T.head text == openBracket bracket && T.last text == closeBracket bracket + then T.init $ T.tail text + else text + surround :: Bracket -> Output -> Output surround bracket x = let (startMetadata, endMetadata) = case x of Output [] -> (Nothing, Nothing) - Output xs -> (head xs ^. annotation, last xs ^. annotation) - (open, closed) = - case bracket of - CurlyBraces -> ("{", "}") - DoubleQuotes -> ("\"", "\"") - Parentheses -> ("(", ")") - SingleQuotes -> ("'", "'") - SquareBrackets -> ("[", "]") - in Output [annotate startMetadata open] <> - x <> Output [annotate endMetadata closed] + Output xs -> (unsafeHead xs ^. annotation, last xs ^. annotation) + in Output [annotate startMetadata (T.singleton $ openBracket bracket)] <> + x <> Output [annotate endMetadata (T.singleton $ closeBracket bracket)] data Delimiter = Commas @@ -149,12 +162,13 @@ -- | Given a position in some transpiled output, find the corresponding -- metadata in the original source. -- Behavior is undefined if `column transPos == 0`. +-- -- TODO Make algorithm functional (assuming this can be cleanly done so). findOriginalPosition :: forall ann. [Annotated ann Text] -> Position -> Maybe ann findOriginalPosition output transPos = - Sem.run $ - Sem.evalState (Position {_line = 1, _column = 0}) $ + Eff.runPureEff $ + Eff.evalState (Position {_line = 1, _column = 0}) $ Effs.runLoop $ do for_ output $ \chunk -> ofor_ (unannotate chunk) $ \char -> do @@ -163,7 +177,7 @@ assign @Position column 0 modifying @Position line succ else modifying @Position column succ - Sem.get >>= \newSrcPos -> + Eff.get >>= \newSrcPos -> when (newSrcPos == transPos) $ breakLoop (Just $ chunk ^. annotation) pure Nothing @@ -176,7 +190,7 @@ quotePosition sourcePosition = Parse.SExpression Nothing - [ Parse.Symbol Nothing "SM.Position" + [ Parse.Symbol Nothing "AxelRuntime_Sourcemap.Position" , Parse.LiteralInt Nothing (sourcePosition ^. line) , Parse.LiteralInt Nothing (sourcePosition ^. column) ] @@ -188,9 +202,11 @@ -- TODO Derive this with Template Haskell (it's currently very brittle) quoteMaybe :: (a -> Expression) -> Maybe a -> Expression -quoteMaybe _ Nothing = Parse.Symbol Nothing "GHCPrelude.Nothing" +quoteMaybe _ Nothing = Parse.Symbol Nothing "AxelRuntime_GHCPrelude.Nothing" quoteMaybe quoter (Just x) = - Parse.SExpression Nothing [Parse.Symbol Nothing "GHCPrelude.Just", quoter x] + Parse.SExpression + Nothing + [Parse.Symbol Nothing "AxelRuntime_GHCPrelude.Just", quoter x] quoteSourceMetadata :: Maybe SourcePosition -> Expression quoteSourceMetadata = quoteMaybe $ quote2Tuple (quoteString, quotePosition) diff --git a/src/Axel/Utils/Monad.hs b/src/Axel/Utils/Monad.hs --- a/src/Axel/Utils/Monad.hs +++ b/src/Axel/Utils/Monad.hs @@ -4,7 +4,7 @@ import Control.Monad (when) -whileM :: (Monad m) => (m Bool) -> m () -> m () +whileM :: (Monad m) => m Bool -> m () -> m () whileM cond action = do cond' <- cond when cond' $ action >> whileM cond action diff --git a/src/Axel/Utils/Recursion.hs b/src/Axel/Utils/Recursion.hs --- a/src/Axel/Utils/Recursion.hs +++ b/src/Axel/Utils/Recursion.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE UndecidableInstances #-} +-- | Utilities for recursing over data structures. module Axel.Utils.Recursion where import Axel.Prelude @@ -27,12 +28,14 @@ mkFmapFromTraverse traverseFn f = runIdentity . traverseFn (pure . f) class Recursive a where - bottomUpTraverse :: Traverse m a a - topDownTraverse :: Traverse m a a + bottomUpTraverse :: Traverse m a a -- ^ Modify every node of a data structure from bottom-up, in a monadic context. + topDownTraverse :: Traverse m a a -- ^ Modify every node of a data structure from top-down, in a monadic context. +-- | Modify every node of a data structure from bottom-up. bottomUpFmap :: (Recursive a) => Fmap a a bottomUpFmap = mkFmapFromTraverse bottomUpTraverse +-- | Modify every node of a data structure from top-down. topDownFmap :: (Recursive a) => Fmap a a topDownFmap = mkFmapFromTraverse topDownTraverse diff --git a/src/Axel/Utils/Text.hs b/src/Axel/Utils/Text.hs --- a/src/Axel/Utils/Text.hs +++ b/src/Axel/Utils/Text.hs @@ -15,6 +15,7 @@ import GHC.Exts (IsString(fromString)) import Language.Haskell.TH.Quote (QuasiQuoter(QuasiQuoter)) +import Language.Haskell.TH.Syntax (lift) capitalize :: Text -> Text capitalize = _head %~ toUpper @@ -23,17 +24,11 @@ s :: QuasiQuoter s = QuasiQuoter - ((\a -> [|fromString a|]) . filter (/= '\r')) + ((\a -> [|fromString $(lift a)|]) . filter (/= '\r')) (error "Cannot use s as a pattern") (error "Cannot use s as a type") (error "Cannot use s as a dec") -handleCharEscapes :: Text -> Text -handleCharEscapes = - T.concatMap $ \case - '\\' -> "\\\\" - c -> T.singleton c - -- TODO This renders very poorly in e.g. Fira Code Mono. bold :: Text -> Text bold = T.map boldCharacter @@ -61,4 +56,4 @@ decodeUtf8Lazy = T.decodeUtf8 . B.toStrict remove :: Text -> Text -> Text -remove needle haystack = T.replace needle "" haystack +remove needle = T.replace needle "" diff --git a/test/Axel/Test/ASTGen.hs b/test/Axel/Test/ASTGen.hs --- a/test/Axel/Test/ASTGen.hs +++ b/test/Axel/Test/ASTGen.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} - module Axel.Test.ASTGen where import Axel.Prelude @@ -50,6 +48,12 @@ Gen.list (Range.linear 0 10) ((,) <$> genExpression <*> genExpression) <*> genExpression +genPatternBinding :: + (MonadGen m) => m (AST.PatternBinding (Maybe SM.Expression)) +genPatternBinding = + AST.PatternBinding Nothing <$> (AST.EIdentifier Nothing <$> genIdentifier) <*> + genExpression + genRawExpression :: (MonadGen m) => m Text genRawExpression = Gen.text (Range.linear 0 10) Gen.unicode @@ -76,6 +80,7 @@ , AST.ELambda <$> genLambda , AST.ELetBlock <$> genLetBlock , AST.ELiteral <$> genLiteral + , AST.EPatternBinding <$> genPatternBinding , AST.ERawExpression Nothing <$> genRawExpression , AST.ERecordDefinition <$> genRecordDefinition , AST.ERecordType <$> genRecordType @@ -90,22 +95,29 @@ ] genDataDeclaration :: - (MonadGen m) => m (AST.DataDeclaration (Maybe SM.Expression)) + (Alternative m, MonadGen m) + => m (AST.DataDeclaration (Maybe SM.Expression)) genDataDeclaration = AST.DataDeclaration Nothing <$> genTypeDefinition <*> - Gen.list (Range.linear 0 10) genExpression + Gen.list (Range.linear 0 10) genExpression <*> + genConstraints genFunctionDefinition :: (Alternative m, MonadGen m) - => m (AST.FunctionDefinition (Maybe SM.Expression)) -genFunctionDefinition = - AST.FunctionDefinition Nothing <$> genIdentifier <*> - Gen.list (Range.linear 0 10) genExpression <*> - genExpression <*> - Gen.list - (Range.linear 0 10) - ((AST.STypeSignature <$> genTypeSignature) <|> - (AST.SFunctionDefinition <$> genFunctionDefinition)) + => Maybe Int + -> m (AST.FunctionDefinition (Maybe SM.Expression)) +genFunctionDefinition numArgs = + let genArgs = + case numArgs of + Just n -> Range.linear n n + Nothing -> Range.linear 0 10 + in AST.FunctionDefinition Nothing <$> genIdentifier <*> + Gen.list genArgs genExpression <*> + genExpression <*> + Gen.list + (Range.linear 0 10) + ((AST.STypeSignature <$> genTypeSignature) <|> + (AST.SFunctionDefinition <$> genFunctionDefinition Nothing)) genPragma :: (MonadGen m) => m (AST.Pragma (Maybe SM.Expression)) genPragma = AST.Pragma Nothing <$> Gen.text (Range.linear 0 10) Gen.ascii @@ -113,7 +125,8 @@ genMacroDefinition :: (Alternative m, MonadGen m) => m (AST.MacroDefinition (Maybe SM.Expression)) -genMacroDefinition = AST.MacroDefinition Nothing <$> genFunctionDefinition +genMacroDefinition = + AST.MacroDefinition Nothing <$> genFunctionDefinition (Just 1) genImport :: (MonadGen m) => m (AST.Import (Maybe SM.Expression)) genImport = @@ -143,9 +156,11 @@ Gen.list (Range.linear 0 10) genIdentifier genNewtypeDeclaration :: - (MonadGen m) => m (AST.NewtypeDeclaration (Maybe SM.Expression)) + (Alternative m, MonadGen m) + => m (AST.NewtypeDeclaration (Maybe SM.Expression)) genNewtypeDeclaration = - AST.NewtypeDeclaration Nothing <$> genTypeDefinition <*> genExpression + AST.NewtypeDeclaration Nothing <$> genTypeDefinition <*> genExpression <*> + genConstraints genRawStatement :: (MonadGen m) => m Text genRawStatement = Gen.text (Range.linear 0 10) Gen.unicode @@ -185,7 +200,7 @@ ((AST.EFunctionApplication <$> genFunctionApplication) <|> (AST.EIdentifier Nothing <$> genIdentifier)) <*> genConstraints <*> - Gen.list (Range.linear 0 10) genFunctionDefinition + Gen.list (Range.linear 0 10) (genFunctionDefinition Nothing) genTypeSignature :: (Alternative m, MonadGen m) => m (AST.TypeSignature (Maybe SM.Expression)) @@ -213,6 +228,6 @@ , AST.STypeSynonym <$> genTypeSynonym ] [ AST.STopLevel <$> genTopLevel - , AST.SFunctionDefinition <$> genFunctionDefinition + , AST.SFunctionDefinition <$> genFunctionDefinition Nothing , AST.SMacroDefinition <$> genMacroDefinition ] diff --git a/test/Axel/Test/DenormalizeSpec.hs b/test/Axel/Test/DenormalizeSpec.hs --- a/test/Axel/Test/DenormalizeSpec.hs +++ b/test/Axel/Test/DenormalizeSpec.hs @@ -8,16 +8,18 @@ import Axel.Sourcemap as SM import qualified Axel.Test.ASTGen as ASTGen -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.Reader as Sem +import Control.Monad +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.Reader.Static as Eff + import Hedgehog import TestUtils (=$=) :: (Functor f, Eq (f ()), Show (f ()), MonadTest m) => f a -> f b -> m () -a =$= b = (() <$ a) === (() <$ b) +a =$= b = void a === void b hprop_normalizeExpression_is_the_inverse_of_denormalizeExpression :: Property hprop_normalizeExpression_is_the_inverse_of_denormalizeExpression = @@ -26,10 +28,10 @@ expr =$= unwrapRight renderError - (Sem.run $ - Sem.runError @Error.Error $ - Sem.runReader (FilePath "") $ - Sem.runReader ([] :: [SM.Expression]) $ + (Eff.runPureEff $ + Eff.runErrorNoCallStack @Error.Error $ + Eff.runReader (FilePath "") $ + Eff.runReader ([] :: [SM.Expression]) $ normalizeExpression (denormalizeExpression expr)) hprop_normalizeStatement_is_the_inverse_of_denormalizeStatement :: Property @@ -39,8 +41,8 @@ stmt =$= unwrapRight renderError - (Sem.run $ - Sem.runError @Error.Error $ - Sem.runReader (FilePath "") $ - Sem.runReader ([] :: [SM.Expression]) $ + (Eff.runPureEff $ + Eff.runErrorNoCallStack @Error.Error $ + Eff.runReader (FilePath "") $ + Eff.runReader ([] :: [SM.Expression]) $ normalizeStatement (denormalizeStatement stmt)) diff --git a/test/Axel/Test/Eff/AppMock.hs b/test/Axel/Test/Eff/AppMock.hs --- a/test/Axel/Test/Eff/AppMock.hs +++ b/test/Axel/Test/Eff/AppMock.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} - module Axel.Test.Eff.AppMock where import Axel.Prelude @@ -17,23 +15,23 @@ import Axel.Test.Eff.ProcessMock import Axel.Test.Eff.ResourceMock -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff type AppEffs - = '[ Effs.Log, Effs.Console, Sem.Error Error.Error, Effs.Ghci, Effs.Process, Effs.FileSystem, Effs.Resource, Sem.Error Text] + = '[ Effs.Log, Effs.Console, Eff.Error Error.Error, Effs.Ghci, Effs.Process, Effs.FileSystem, Effs.Resource, Eff.Error Text] runApp :: - (processEffs ~ '[ Effs.FileSystem, Effs.Resource, Sem.Error Text]) + (processEffs ~ '[ Effs.FileSystem, Effs.Resource, Eff.Error Text]) => ConsoleState -> FileSystemState -> GhciState -> ProcessState processEffs - -> Sem.Sem AppEffs a - -> ( FileSystemState - , (ProcessState processEffs, (GhciState, (ConsoleState, a)))) + -> Eff.Eff AppEffs a + -> ( (((a, ConsoleState), GhciState), ProcessState processEffs) + , FileSystemState) runApp origConsoleState origFSState origGhciState origProcState = - Sem.run . + Eff.runPureEff . unsafeRunError id . runResource . runFileSystem origFSState . @@ -42,19 +40,19 @@ unsafeRunError renderError . runConsole origConsoleState . Effs.ignoreLog evalApp :: - (processEffs ~ '[ Effs.FileSystem, Effs.Resource, Sem.Error Text]) + (processEffs ~ '[ Effs.FileSystem, Effs.Resource, Eff.Error Text]) => ConsoleState -> FileSystemState -> GhciState -> ProcessState processEffs - -> Sem.Sem AppEffs a + -> Eff.Eff AppEffs a -> a evalApp origConsoleState origFSState origGhciState origProcState = - snd . - snd . - snd . snd . runApp origConsoleState origFSState origGhciState origProcState + fst . + fst . + fst . fst . runApp origConsoleState origFSState origGhciState origProcState -evalApp' :: Sem.Sem AppEffs a -> a +evalApp' :: Eff.Eff AppEffs a -> a evalApp' = evalApp origConsoleState origFSState origGhciState origProcState where origConsoleState = mkConsoleState diff --git a/test/Axel/Test/Eff/ConsoleMock.hs b/test/Axel/Test/Eff/ConsoleMock.hs --- a/test/Axel/Test/Eff/ConsoleMock.hs +++ b/test/Axel/Test/Eff/ConsoleMock.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Test.Eff.ConsoleMock where @@ -10,9 +8,11 @@ import Control.Lens -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.State as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.State.Static.Local as Eff import TestUtils @@ -28,13 +28,13 @@ mkConsoleState = ConsoleState {_consoleOutput = ""} runConsole :: - forall effs a. (Sem.Member (Sem.Error Text) effs) + forall effs a. (Eff.Error Text :> effs) => ConsoleState - -> Sem.Sem (Effs.Console ': effs) a - -> Sem.Sem effs (ConsoleState, a) -runConsole origState action = Sem.runState origState $ Sem.reinterpret go action + -> Eff.Eff (Effs.Console ': effs) a + -> Eff.Eff effs (a, ConsoleState) +runConsole origState = Eff.reinterpret (Eff.runState origState) (const go) where - go :: Console m b -> Sem.Sem (Sem.State ConsoleState ': effs) b + go :: Console m b -> Eff.Eff (Eff.State ConsoleState ': effs) b go GetTerminalSize = throwInterpretError "GetTerminalSize" "Not implemented!" - go (PutStr str) = Sem.modify $ consoleOutput %~ (<> str) + go (PutStr str) = Eff.modify $ consoleOutput %~ (<> str) diff --git a/test/Axel/Test/Eff/ConsoleSpec.hs b/test/Axel/Test/Eff/ConsoleSpec.hs --- a/test/Axel/Test/Eff/ConsoleSpec.hs +++ b/test/Axel/Test/Eff/ConsoleSpec.hs @@ -6,14 +6,14 @@ import qualified Axel.Eff.Console as Console import qualified Axel.Test.Eff.ConsoleMock as Mock -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff -import Test.Tasty.Hspec +import Test.Hspec import TestUtils -spec_Console :: SpecWith () +spec_Console :: Spec spec_Console = describe "putStrLn" $ do it "prints to the console with a trailing newline" $ do @@ -22,5 +22,7 @@ let expected = Mock.ConsoleState {Mock._consoleOutput = "line1\nline2\n"} let result = unwrapRight id $ - Sem.run . Sem.runError @Text . Mock.runConsole origState $ action - result `shouldBe` (expected, ()) + Eff.runPureEff . + Eff.runErrorNoCallStack @Text . Mock.runConsole origState $ + action + result `shouldBe` ((), expected) diff --git a/test/Axel/Test/Eff/FileSystemMock.hs b/test/Axel/Test/Eff/FileSystemMock.hs --- a/test/Axel/Test/Eff/FileSystemMock.hs +++ b/test/Axel/Test/Eff/FileSystemMock.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} module Axel.Test.Eff.FileSystemMock where @@ -15,9 +13,11 @@ import Data.Maybe import qualified Data.Text as T -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.State as Sem +import Effectful ((:>)) +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.State.Static.Local as Eff import TestUtils @@ -120,8 +120,7 @@ type instance IxValue FSNode = FSNode instance Ixed FSNode where - ix :: - (Applicative f) => FilePath -> (FSNode -> f FSNode) -> FSNode -> f FSNode + ix :: FilePath -> Traversal' FSNode FSNode ix path f root = case lookupNode pathSegments root of Just node -> @@ -167,20 +166,18 @@ dropLeadingSlash x = x absify :: - (Sem.Member (Sem.State FileSystemState) effs) - => FilePath - -> Sem.Sem effs FilePath + (Eff.State FileSystemState :> effs) => FilePath -> Eff.Eff effs FilePath absify relativePath = - absifyPath relativePath <$> Sem.gets (^. fsCurrentDirectory) + absifyPath relativePath <$> Eff.gets (^. fsCurrentDirectory) runFileSystem :: - forall effs a. (Sem.Member (Sem.Error Text) effs) + forall effs a. (Eff.Error Text :> effs) => FileSystemState - -> Sem.Sem (Effs.FileSystem ': effs) a - -> Sem.Sem effs (FileSystemState, a) -runFileSystem origState = Sem.runState origState . Sem.reinterpret go + -> Eff.Eff (Effs.FileSystem ': effs) a + -> Eff.Eff effs (a, FileSystemState) +runFileSystem origState = Eff.reinterpret (Eff.runState origState) (const go) where - go :: FileSystem m a' -> Sem.Sem (Sem.State FileSystemState ': effs) a' + go :: FileSystem m a' -> Eff.Eff (Eff.State FileSystemState ': effs) a' go (AppendFile relativePath addedContents) = do oldContents <- go $ ReadFile relativePath let newContents = oldContents <> addedContents @@ -190,13 +187,13 @@ go $ WriteFile dest contents go (CreateDirectoryIfMissing createParents relativePath) = do path <- absify relativePath - parentNode <- Sem.gets (^. fsRoot . at (takeDirectory path)) + parentNode <- Eff.gets (^. fsRoot . at (takeDirectory path)) case parentNode of Just _ -> - Sem.modify $ fsRoot . at path ?~ Directory (takeFileName path) [] + Eff.modify $ fsRoot . at path ?~ Directory (takeFileName path) [] Nothing -> if createParents - then Sem.modify $ fsRoot %~ \origRoot -> + then Eff.modify $ fsRoot %~ \origRoot -> fst (foldl (\(root, segments) pathSegment -> @@ -216,15 +213,15 @@ ("Missing parents for directory: " <> op FilePath path) go (DoesDirectoryExist relativePath) = do path <- absify relativePath - directoryNode <- Sem.gets (^. fsRoot . at path) + directoryNode <- Eff.gets (^. fsRoot . at path) pure $ case directoryNode of Just (Directory _ _) -> True _ -> False - go GetCurrentDirectory = Sem.gets (^. fsCurrentDirectory) + go GetCurrentDirectory = Eff.gets (^. fsCurrentDirectory) go (GetDirectoryContents relativePath) = do path <- absify relativePath - directoryNode <- Sem.gets (^. fsRoot . at path) + directoryNode <- Eff.gets (^. fsRoot . at path) case directoryNode of Just (Directory _ children) -> pure $ map (^. fsPath) children _ -> @@ -233,14 +230,14 @@ "getDirectoryContents" ("No such directory: " <> op FilePath path) go GetTemporaryDirectory = do - tempCounter <- Sem.gets (^. fsTempCounter) - Sem.modify $ fsTempCounter %~ (+ 1) + tempCounter <- Eff.gets (^. fsTempCounter) + Eff.modify $ fsTempCounter %~ (+ 1) let tempDirName = FilePath "/tmp" FilePath (showText tempCounter) go $ CreateDirectoryIfMissing True tempDirName pure tempDirName go (ReadFile relativePath) = do path <- absify relativePath - fileNode <- Sem.gets (^. fsRoot . at path) + fileNode <- Eff.gets (^. fsRoot . at path) case fileNode of Just (File _ contents) -> pure contents _ -> @@ -250,8 +247,8 @@ ("No such file: " <> op FilePath path) go (RemoveFile relativePath) = do path <- absify relativePath - Sem.gets (deleteNode (splitDirectories path) . (^. fsRoot)) >>= \case - Just newRoot -> Sem.modify $ fsRoot .~ newRoot + Eff.gets (deleteNode (splitDirectories path) . (^. fsRoot)) >>= \case + Just newRoot -> Eff.modify $ fsRoot .~ newRoot Nothing -> throwInterpretError @FileSystemState @@ -259,7 +256,7 @@ ("No such file: " <> op FilePath path) go (SetCurrentDirectory relativePath) = do path <- absify relativePath - Sem.modify $ fsCurrentDirectory .~ path + Eff.modify $ fsCurrentDirectory .~ path go (WriteFile relativePath contents) = do path <- absify relativePath - Sem.modify $ fsRoot . at path ?~ File (takeFileName path) contents + Eff.modify $ fsRoot . at path ?~ File (takeFileName path) contents diff --git a/test/Axel/Test/Eff/FileSystemSpec.hs b/test/Axel/Test/Eff/FileSystemSpec.hs --- a/test/Axel/Test/Eff/FileSystemSpec.hs +++ b/test/Axel/Test/Eff/FileSystemSpec.hs @@ -9,14 +9,14 @@ import Control.Lens -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff -import Test.Tasty.Hspec +import Test.Hspec import TestUtils -spec_FileSystem :: SpecWith () +spec_FileSystem :: Spec spec_FileSystem = do describe "getDirectoryContentsRec" $ do it "gets the files inside a directory and all its subdirectories" $ do @@ -34,9 +34,11 @@ ] ] let expected = [FilePath "dir1/file1", FilePath "dir1/dir2/file2"] - case Sem.run . Sem.runError . Mock.runFileSystem origState $ action of + case Eff.runPureEff . Eff.runErrorNoCallStack . + Mock.runFileSystem origState $ + action of Left err -> failSpec err - Right result -> result `shouldBe` (origState, expected) + Right result -> result `shouldBe` (expected, origState) describe "withCurrentDirectory" $ do it "changes the directory and resets it afterwards" $ do let action = do @@ -59,9 +61,11 @@ Mock.File (FilePath "insideDir") "insideDirContents") & (Mock.fsRoot . at (FilePath "outsideDir") ?~ Mock.File (FilePath "outsideDir") "outsideDirContents") - case Sem.run . Sem.runError . Mock.runFileSystem origState $ action of + case Eff.runPureEff . Eff.runErrorNoCallStack . + Mock.runFileSystem origState $ + action of Left err -> failSpec err - Right result -> result `shouldBe` (expected, ()) + Right result -> result `shouldBe` ((), expected) describe "withTemporaryDirectory" $ do it "creates a temporary directory and resets the current directory afterwards" $ do @@ -88,6 +92,8 @@ (FilePath "1") [Mock.File (FilePath "insideTemp1") "insideTemp1Contents"]) & (Mock.fsTempCounter .~ 2) - case Sem.run . Sem.runError . Mock.runFileSystem origState $ action of + case Eff.runPureEff . Eff.runErrorNoCallStack . + Mock.runFileSystem origState $ + action of Left err -> failSpec err - Right result -> result `shouldBe` (expected, ()) + Right result -> result `shouldBe` ((), expected) diff --git a/test/Axel/Test/Eff/GhciMock.hs b/test/Axel/Test/Eff/GhciMock.hs --- a/test/Axel/Test/Eff/GhciMock.hs +++ b/test/Axel/Test/Eff/GhciMock.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Test.Eff.GhciMock where @@ -9,10 +7,12 @@ import Axel.Eff.Ghci as Effs import Control.Lens -import Polysemy -import Polysemy.Error as Effs -import Polysemy.State as Effs +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Error.Static +import Effectful.State.Static.Local + import TestUtils data GhciState = @@ -28,13 +28,13 @@ mkGhciState = GhciState [] runGhci :: - forall effs a. (Member (Effs.Error Text) effs) + forall effs a. (Error Text :> effs) => GhciState - -> Sem (Effs.Ghci ': effs) a - -> Sem effs (GhciState, a) -runGhci origState action = runState origState $ reinterpret go action + -> Eff (Effs.Ghci ': effs) a + -> Eff effs (a, GhciState) +runGhci origState = reinterpret (runState origState) (const go) where - go :: Ghci m b -> Sem (Effs.State GhciState ': effs) b + go :: Ghci m b -> Eff (State GhciState ': effs) b go (Exec _ command) = do modify @GhciState $ ghciExecutionLog %~ (|> command) gets @GhciState (uncons . (^. ghciMockResults)) >>= \case diff --git a/test/Axel/Test/Eff/ProcessMock.hs b/test/Axel/Test/Eff/ProcessMock.hs --- a/test/Axel/Test/Eff/ProcessMock.hs +++ b/test/Axel/Test/Eff/ProcessMock.hs @@ -1,27 +1,27 @@ -{-# LANGUAGE GADTs #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Axel.Test.Eff.ProcessMock where import Axel.Prelude +import Axel.Eff ((:>>)) import Axel.Eff.FileSystem as Effs import Axel.Eff.Process as Effs import Control.Lens -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.State as Sem +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.State.Static.Local as Eff import System.Exit import TestUtils newtype ProcessResult effs = - ProcessResult ((ExitCode, Maybe (Text, Text)), Sem.Sem effs ()) + ProcessResult ((ExitCode, Maybe (Text, Text)), Eff.Eff effs ()) -- | We are pretending that all `ProcessResult`s are unique no matter what, for simplicity's sake. instance Eq (ProcessResult effs) where @@ -52,13 +52,14 @@ } runProcess :: - forall effs a. (Sem.Members '[ Sem.Error Text, Effs.FileSystem] effs) + forall effs a. ('[ Eff.Error Text, Effs.FileSystem] :>> effs) => ProcessState effs - -> Sem.Sem (Effs.Process ': effs) a - -> Sem.Sem effs (ProcessState effs, a) -runProcess origProcessState = Sem.runState origProcessState . Sem.reinterpret go + -> Eff.Eff (Effs.Process ': effs) a + -> Eff.Eff effs (a, ProcessState effs) +runProcess origProcessState = + Eff.reinterpret (Eff.runState origProcessState) (const go) where - go :: Process m a' -> Sem.Sem (Sem.State (ProcessState effs) ': effs) a' + go :: Process m a' -> Eff.Eff (Eff.State (ProcessState effs) ': effs) a' go (CreateIndependentProcess _) = throwInterpretError @(ProcessState effs) @@ -69,7 +70,7 @@ @(ProcessState effs) "CreatePassthroughProcess" "Not implemented!" - go GetArgs = Sem.gets (^. procMockArgs) + go GetArgs = Eff.gets (^. procMockArgs) go (HandleGetContents _) = throwInterpretError @(ProcessState effs) diff --git a/test/Axel/Test/Eff/ResourceMock.hs b/test/Axel/Test/Eff/ResourceMock.hs --- a/test/Axel/Test/Eff/ResourceMock.hs +++ b/test/Axel/Test/Eff/ResourceMock.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} - module Axel.Test.Eff.ResourceMock where import Axel.Prelude @@ -7,10 +5,12 @@ import Axel.Eff.Resource as Effs import Axel.Utils.FilePath -import qualified Polysemy as Sem +import qualified Effectful as Eff +import qualified Effectful.Dispatch.Dynamic as Eff -runResource :: Sem.Sem (Effs.Resource ': effs) a -> Sem.Sem effs a +runResource :: Eff.Eff (Effs.Resource ': effs) a -> Eff.Eff effs a runResource = - Sem.interpret $ \case - GetResourcePath (ResourceId resourceId) -> - pure (FilePath "dataFiles/resources" FilePath resourceId) + Eff.interpret $ \_ -> + \case + GetResourcePath (ResourceId resourceId) -> + pure (FilePath "dataFiles/resources" FilePath resourceId) diff --git a/test/Axel/Test/Eff/ResourceSpec.hs b/test/Axel/Test/Eff/ResourceSpec.hs --- a/test/Axel/Test/Eff/ResourceSpec.hs +++ b/test/Axel/Test/Eff/ResourceSpec.hs @@ -7,14 +7,14 @@ import Axel.Test.Eff.FileSystemMock as Mock import Axel.Test.Eff.ResourceMock as Mock -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff -import Test.Tasty.Hspec +import Test.Hspec import TestUtils -spec_Resource :: SpecWith () +spec_Resource :: Spec spec_Resource = describe "readResource" $ do it "reads a resource's contents from the file system" $ do @@ -32,8 +32,9 @@ ] ] let expected = "res1Contents" - case Sem.run . - Sem.runError . Mock.runFileSystem origFSState . Mock.runResource $ + case Eff.runPureEff . + Eff.runErrorNoCallStack . + Mock.runFileSystem origFSState . Mock.runResource $ action of Left err -> failSpec err - Right result -> result `shouldBe` (origFSState, expected) + Right result -> result `shouldBe` (expected, origFSState) diff --git a/test/Axel/Test/Haskell/CabalSpec.hs b/test/Axel/Test/Haskell/CabalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Axel/Test/Haskell/CabalSpec.hs @@ -0,0 +1,157 @@ +{- HLINT ignore "Redundant do" -} +{-# LANGUAGE PartialTypeSignatures #-} + +module Axel.Test.Haskell.CabalSpec where + +import Axel.Prelude + +import Test.Hspec + +-- TODO Flesh out `ProcessMock.runProcess` with the new `Process` actions, +-- so that we can re-enable this test suite. +spec_Cabal :: Spec +spec_Cabal = pure () +{- + +import Axel.Eff.Error +import Axel.Eff.FileSystem as FS +import Axel.Eff.Process +import Axel.Haskell.Cabal as Cabal +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 Data.Functor +import qualified Data.Map as M + +import qualified Polysemy as Sem +import qualified Polysemy.Error as Sem + +import System.Exit + +import TestUtils + +spec_Cabal :: Spec +spec_Cabal = do + describe "addDependency" $ do + it "adds a package dependency to a project" $ do + let action = + Cabal.addDependency "foo-1.2.3.4" (FilePath "project/path") + let origFSState = + Mock.mkFileSystemState + [ Mock.Directory + (FilePath "project") + [ Mock.Directory + (FilePath "path") + [ Mock.File + (FilePath "package.yaml") + "dependencies:\n- asdf-5.6.7" + ] + ] + ] + let expectedFSState = + origFSState & Mock.fsRoot . + at (FilePath "project/path/package.yaml") ?~ + Mock.File + (FilePath "package.yaml") + "dependencies:\n- foo-1.2.3.4\n- asdf-5.6.7\n" + case Sem.run . Eff.runErrorNoCallStack . Mock.runFileSystem origFSState $ action of + Left err -> failSpec err + Right (result, ()) -> result `shouldBe` expectedFSState + describe "buildProject" $ do + it "builds a project" $ do + let action = Cabal.buildProject M.empty (FilePath "project/foo") + let origConsoleState = Mock.mkConsoleState + let origFSState = + Mock.mkFileSystemState + [ Mock.Directory + (FilePath "project") + [Mock.Directory (FilePath "foo") []] + ] + let origProcState = + Mock.mkProcessState + [] + [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 --ghc-options='-ddump-json'", Just "")] + fsState ^. Mock.fsCurrentDirectory `shouldBe` FilePath "/" + case Sem.run . Eff.runErrorNoCallStack @Error . Eff.runErrorNoCallStack @Text . + Mock.runFileSystem origFSState . + Mock.runProcess origProcState . + Mock.runConsole origConsoleState $ + action of + Left err -> failSpec $ renderError err + Right (Left err) -> failSpec err + Right (Right (fsState, (procState, (consoleState, x)))) -> + expectation x (consoleState, fsState, procState) + describe "createProject" $ do + it "creates a new project" $ do + let action = Cabal.createProject "newProject" + let origFSState = Mock.mkFileSystemState [] + let origProcState = + Mock.mkProcessState + [] + [ ProcessResult + ( (ExitSuccess, Just ("", "")) + , FS.createDirectoryIfMissing False (FilePath "newProject")) + , ProcessResult ((ExitSuccess, Just ("", "")), pure ()) + ] + let expectation result (fsState, procState) = do + result `shouldBe` () + procState ^. Mock.procExecutionLog `shouldBe` + [ ("stack new newProject new-template", Just "") + , ( "stack config set resolver " <> stackageResolverWithAxel + , Just "") + ] + fsState ^. Mock.fsCurrentDirectory `shouldBe` FilePath "/" + fsState ^. Mock.fsRoot . at (FilePath "newProject") . _Just . + Mock.fsPath `shouldBe` + FilePath "newProject" + case Sem.run . Eff.runErrorNoCallStack @Error . Eff.runErrorNoCallStack @Text . + Mock.runFileSystem origFSState . + Mock.runProcess origProcState $ + action of + Left err -> failSpec $ renderError err + Right (Left err) -> failSpec err + Right (Right (fsState, (procState, x))) -> + expectation x (fsState, procState) + describe "runProject" $ do + it "runs a project" $ do + let action = Cabal.runProject (FilePath "project/foo") + let origConsoleState = Mock.mkConsoleState + let origFSState = + Mock.mkFileSystemState + [ Mock.Directory + (FilePath "project") + [Mock.Directory (FilePath "foo") []] + ] + let origProcState = + Mock.mkProcessState + [] + [ ProcessResult + ( ( ExitSuccess + , Just ("", "foo:lib\nfoo:exe:foo-exe\nfoo:test:foo-test")) + , pure ()) + , ProcessResult ((ExitSuccess, Nothing), pure ()) + ] + let expectation result (consoleState, fsState, procState) = do + result `shouldBe` () + procState ^. Mock.procExecutionLog `shouldBe` + [("stack ide targets", Just ""), ("stack exec foo-exe", Nothing)] + fsState ^. Mock.fsCurrentDirectory `shouldBe` FilePath "/" + consoleState ^. Mock.consoleOutput `shouldBe` "Running foo-exe...\n" + case Sem.run . Eff.runErrorNoCallStack @Error . Eff.runErrorNoCallStack @Text . + Mock.runFileSystem origFSState . + Mock.runProcess origProcState . + Mock.runConsole origConsoleState $ + action of + Left err -> failSpec $ renderError err + Right (Left err) -> failSpec err + Right (Right (fsState, (procState, (consoleState, x)))) -> + expectation x (consoleState, fsState, procState) +-} diff --git a/test/Axel/Test/Haskell/ErrorSpec.hs b/test/Axel/Test/Haskell/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Axel/Test/Haskell/ErrorSpec.hs @@ -0,0 +1,69 @@ +module Axel.Test.Haskell.ErrorSpec where + +import Axel.Prelude + +import Axel.Eff.App (AppEffs) +import qualified Axel.Eff.Console as Effs +import qualified Axel.Eff.Error as Effs +import qualified Axel.Eff.FileSystem as Effs +import qualified Axel.Eff.Ghci as Effs +import qualified Axel.Eff.Ghci as Ghci +import qualified Axel.Eff.Log as Effs +import qualified Axel.Eff.Process as Effs +import qualified Axel.Eff.Random as Effs +import qualified Axel.Eff.Resource as Effs +import qualified Axel.Eff.Time as Effs +import Axel.Haskell.File +import Axel.Sourcemap as SM +import Axel.Utils.FilePath +import Axel.Utils.Text + +import Control.Lens + +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.State.Static.Local as Eff + +import Test.Tasty +import Test.Tasty.Golden + +runApp :: Eff.Eff AppEffs a -> IO (Either Effs.Error a) +runApp = + Eff.runEff . + Effs.runTime . + Effs.runRandom . + Effs.runResource . + Effs.runProcess . + Effs.runGhci . + Effs.runFileSystem . + Effs.runConsole . Effs.ignoreLog . Eff.runErrorNoCallStack + +test_errors_golden :: IO TestTree +test_errors_golden = do + axelFiles <- + map (FilePath . T.pack) <$> + findByExtension [".axel_golden"] "test/Axel/Test/Haskell/errors" + pure $ + testGroup "error golden tests" $ do + axelFile <- axelFiles + let hsFile = replaceExtension axelFile "error_golden" + let transpiled = do + axelSource <- T.readFile $ T.unpack (op FilePath axelFile) + output <- + runApp $ + Eff.evalState (M.empty :: ModuleInfo) $ + Ghci.withGhci $ transpileSource (takeBaseName axelFile) axelSource + case output of + Right _ -> + error $ + op FilePath axelFile <> " should have errored, but it didn't!" + Left err -> pure $ encodeUtf8Lazy $ Effs.renderError err + pure $ + goldenVsString + (T.unpack . op FilePath $ takeBaseName axelFile) + (T.unpack . op FilePath $ hsFile) + transpiled diff --git a/test/Axel/Test/Haskell/StackSpec.hs b/test/Axel/Test/Haskell/StackSpec.hs deleted file mode 100644 --- a/test/Axel/Test/Haskell/StackSpec.hs +++ /dev/null @@ -1,158 +0,0 @@ -{- HLINT ignore "Redundant do" -} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PartialTypeSignatures #-} - -module Axel.Test.Haskell.StackSpec where - -import Axel.Prelude - -import Test.Tasty.Hspec - --- TODO Flesh out `ProcessMock.runProcess` with the new `Process` actions, --- so that we can re-enable this test suite. -spec_Stack :: SpecWith () -spec_Stack = pure () -{- - -import Axel.Eff.Error -import Axel.Eff.FileSystem as FS -import Axel.Eff.Process -import Axel.Haskell.Stack as Stack -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 Data.Functor -import qualified Data.Map as M - -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem - -import System.Exit - -import TestUtils - -spec_Stack :: SpecWith () -spec_Stack = do - describe "addStackDependency" $ do - it "adds a Stackage dependency to a Stack project" $ do - let action = - Stack.addStackDependency "foo-1.2.3.4" (FilePath "project/path") - let origFSState = - Mock.mkFileSystemState - [ Mock.Directory - (FilePath "project") - [ Mock.Directory - (FilePath "path") - [ Mock.File - (FilePath "package.yaml") - "dependencies:\n- asdf-5.6.7" - ] - ] - ] - let expectedFSState = - origFSState & Mock.fsRoot . - at (FilePath "project/path/package.yaml") ?~ - Mock.File - (FilePath "package.yaml") - "dependencies:\n- foo-1.2.3.4\n- asdf-5.6.7\n" - case Sem.run . Sem.runError . Mock.runFileSystem origFSState $ action of - Left err -> failSpec err - Right (result, ()) -> result `shouldBe` expectedFSState - describe "buildStackProject" $ do - it "builds a Stack project" $ do - let action = Stack.buildStackProject M.empty (FilePath "project/foo") - let origConsoleState = Mock.mkConsoleState - let origFSState = - Mock.mkFileSystemState - [ Mock.Directory - (FilePath "project") - [Mock.Directory (FilePath "foo") []] - ] - let origProcState = - Mock.mkProcessState - [] - [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 --ghc-options='-ddump-json'", Just "")] - fsState ^. Mock.fsCurrentDirectory `shouldBe` FilePath "/" - case Sem.run . Sem.runError @Error . Sem.runError @Text . - Mock.runFileSystem origFSState . - Mock.runProcess origProcState . - Mock.runConsole origConsoleState $ - action of - Left err -> failSpec $ renderError err - Right (Left err) -> failSpec err - Right (Right (fsState, (procState, (consoleState, x)))) -> - expectation x (consoleState, fsState, procState) - describe "createStackProject" $ do - it "creates a new Stack project" $ do - let action = Stack.createStackProject "newProject" - let origFSState = Mock.mkFileSystemState [] - let origProcState = - Mock.mkProcessState - [] - [ ProcessResult - ( (ExitSuccess, Just ("", "")) - , FS.createDirectoryIfMissing False (FilePath "newProject")) - , ProcessResult ((ExitSuccess, Just ("", "")), pure ()) - ] - let expectation result (fsState, procState) = do - result `shouldBe` () - procState ^. Mock.procExecutionLog `shouldBe` - [ ("stack new newProject new-template", Just "") - , ( "stack config set resolver " <> stackageResolverWithAxel - , Just "") - ] - fsState ^. Mock.fsCurrentDirectory `shouldBe` FilePath "/" - fsState ^. Mock.fsRoot . at (FilePath "newProject") . _Just . - Mock.fsPath `shouldBe` - FilePath "newProject" - case Sem.run . Sem.runError @Error . Sem.runError @Text . - Mock.runFileSystem origFSState . - Mock.runProcess origProcState $ - action of - Left err -> failSpec $ renderError err - Right (Left err) -> failSpec err - Right (Right (fsState, (procState, x))) -> - expectation x (fsState, procState) - describe "runStackProject" $ do - it "runs a Stack project" $ do - let action = Stack.runStackProject (FilePath "project/foo") - let origConsoleState = Mock.mkConsoleState - let origFSState = - Mock.mkFileSystemState - [ Mock.Directory - (FilePath "project") - [Mock.Directory (FilePath "foo") []] - ] - let origProcState = - Mock.mkProcessState - [] - [ ProcessResult - ( ( ExitSuccess - , Just ("", "foo:lib\nfoo:exe:foo-exe\nfoo:test:foo-test")) - , pure ()) - , ProcessResult ((ExitSuccess, Nothing), pure ()) - ] - let expectation result (consoleState, fsState, procState) = do - result `shouldBe` () - procState ^. Mock.procExecutionLog `shouldBe` - [("stack ide targets", Just ""), ("stack exec foo-exe", Nothing)] - fsState ^. Mock.fsCurrentDirectory `shouldBe` FilePath "/" - consoleState ^. Mock.consoleOutput `shouldBe` "Running foo-exe...\n" - case Sem.run . Sem.runError @Error . Sem.runError @Text . - Mock.runFileSystem origFSState . - Mock.runProcess origProcState . - Mock.runConsole origConsoleState $ - action of - Left err -> failSpec $ renderError err - Right (Left err) -> failSpec err - Right (Right (fsState, (procState, (consoleState, x)))) -> - expectation x (consoleState, fsState, procState) --} diff --git a/test/Axel/Test/MacrosSpec.hs b/test/Axel/Test/MacrosSpec.hs --- a/test/Axel/Test/MacrosSpec.hs +++ b/test/Axel/Test/MacrosSpec.hs @@ -10,11 +10,11 @@ import Data.Generics.Uniplate.Zipper -import Test.Tasty.Hspec hiding (focus) +import Test.Hspec hiding (focus) import TestUtils -spec_Macros :: SpecWith () +spec_Macros :: Spec spec_Macros = do describe "isStatementFocused" $ do it "returns if a zipper is focused on a statement's expression" $ do diff --git a/test/Axel/Test/NormalizeSpec.hs b/test/Axel/Test/NormalizeSpec.hs --- a/test/Axel/Test/NormalizeSpec.hs +++ b/test/Axel/Test/NormalizeSpec.hs @@ -8,9 +8,9 @@ import Axel.Sourcemap as SM import qualified Axel.Test.Parse.ASTGen as Parse.ASTGen -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.Reader as Sem +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.Reader.Static as Eff import Hedgehog @@ -23,7 +23,7 @@ expr === denormalizeExpression (unwrapRight renderError $ - Sem.run . - Sem.runError @Error.Error . - Sem.runReader (FilePath "") . Sem.runReader ([] :: [SM.Expression]) $ + Eff.runPureEff . + Eff.runErrorNoCallStack @Error.Error . + Eff.runReader (FilePath "") . Eff.runReader ([] :: [SM.Expression]) $ normalizeExpression expr) diff --git a/test/Axel/Test/Parse/ASTGen.hs b/test/Axel/Test/Parse/ASTGen.hs --- a/test/Axel/Test/Parse/ASTGen.hs +++ b/test/Axel/Test/Parse/ASTGen.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} - module Axel.Test.Parse.ASTGen where import Axel.Prelude diff --git a/test/Axel/Test/Parse/ASTSpec.hs b/test/Axel/Test/Parse/ASTSpec.hs --- a/test/Axel/Test/Parse/ASTSpec.hs +++ b/test/Axel/Test/Parse/ASTSpec.hs @@ -6,9 +6,9 @@ import Axel.Parse.AST import Axel.Utils.Recursion -import Test.Tasty.Hspec +import Test.Hspec -spec_AST :: SpecWith () +spec_AST :: Spec spec_AST = do describe "RecursiveZipper instance" $ do it @@ -26,13 +26,13 @@ , SExpression 8 [] ] ] - let f (LiteralChar ann x) = LiteralChar (succ ann) x - f (LiteralFloat ann x) = LiteralFloat (succ ann) x - f (LiteralInt ann x) = LiteralInt (succ ann) x - f (LiteralString ann x) = LiteralString (succ ann) x - f (SExpression ann xs) = SExpression (succ ann) xs - f (Symbol ann x) = Symbol (succ ann) x - bottomUpFmap f ast `shouldBe` (succ <$> ast) + let f (LiteralChar ann x) = LiteralChar (ann + 1) x + f (LiteralFloat ann x) = LiteralFloat (ann + 1) x + f (LiteralInt ann x) = LiteralInt (ann + 1) x + f (LiteralString ann x) = LiteralString (ann + 1) x + f (SExpression ann xs) = SExpression (ann + 1) xs + f (Symbol ann x) = Symbol (ann + 1) x + bottomUpFmap f ast `shouldBe` ((+ 1) <$> ast) it "correctly implements zipperTopDownTraverse (by testing derived methods)" $ do let ast :: Expression Int ast = @@ -47,9 +47,10 @@ , SExpression 8 [] ] ] - let f (LiteralChar ann x) = LiteralChar (succ ann) x - f (LiteralInt ann x) = LiteralInt (succ ann) x - f (LiteralString ann x) = LiteralString (succ ann) x - f (SExpression ann xs) = SExpression (succ ann) xs - f (Symbol ann x) = Symbol (succ ann) x - topDownFmap f ast `shouldBe` (succ <$> ast) + let f (LiteralChar ann x) = LiteralChar (ann + 1) x + f (LiteralInt ann x) = LiteralInt (ann + 1) x + f (LiteralString ann x) = LiteralString (ann + 1) x + f (SExpression ann xs) = SExpression (ann + 1) xs + f (Symbol ann x) = Symbol (ann + 1) x + f _ = error "Impossible!" + topDownFmap f ast `shouldBe` ((+ 1) <$> ast) diff --git a/test/Axel/Test/ParseSpec.hs b/test/Axel/Test/ParseSpec.hs --- a/test/Axel/Test/ParseSpec.hs +++ b/test/Axel/Test/ParseSpec.hs @@ -10,17 +10,23 @@ import Axel.Parse.AST import Axel.Utils.Text -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem +import Control.Monad -import Test.Tasty.Hspec +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Test.Hspec + import TestUtils parseSingle :: Text -> Expression () parseSingle = (() <$) . unsafeParseSingle Nothing -spec_Parse :: SpecWith () +spec_Parse :: Spec spec_Parse = do describe "parseSingle" $ do it "can parse a character literal" $ do @@ -41,6 +47,29 @@ it "can parse a string literal" $ do let result = LiteralString () "a \x1000 \"b" parseSingle "\"a \x1000 \\\"b\"" `shouldBe` result + it + "can parse string literals with escaped double quotes at the boundaries (regression: #79)" $ do + let result = LiteralString () "a \x1000 \"" + parseSingle "\"a \x1000 \\\"\"" `shouldBe` result + let result = LiteralString () "a \x1000 \"\"" + parseSingle "\"a \x1000 \\\"\\\"\"" `shouldBe` result + let result = LiteralString () "\"" + parseSingle "\"\\\"\"" `shouldBe` result + let result = LiteralString () "\"\"" + parseSingle "\"\\\"\\\"\"" `shouldBe` result + let result = LiteralString () "\"\" foo" + parseSingle "\"\\\"\\\" foo\"" `shouldBe` result + let result = LiteralString () "\"\"\"" + parseSingle "\"\\\"\\\"\\\"\"" `shouldBe` result + it + "can parse a string literal with a double quote at the end (regression: #79)" $ do + let result = LiteralString () "a \x1000 \"" + parseSingle "\"a \x1000 \\\"\"" `shouldBe` result + it "can parse a string literal with escaped unprintables" $ do + let result = LiteralString () "\0" + parseSingle "\"\\0\"" `shouldBe` result + let result = LiteralString () "\NUL" + parseSingle "\"\\NUL\"" `shouldBe` result it "can parse a quasiquoted expression" $ do let result = SExpression @@ -99,7 +128,8 @@ () [Symbol () "bar", Symbol () "x", Symbol () "y", Symbol () "z"] ] - case Sem.run . Sem.runError $ parseMultiple Nothing input of + case Eff.runPureEff . Eff.runErrorNoCallStack $ + parseMultiple Nothing input of Left err -> failSpec $ renderError err Right x -> map (() <$) x `shouldBe` result describe "parseSource" $ do @@ -136,6 +166,13 @@ "butThisaXEL_SYMBOL_HYPHEN_aXEL_SYMBOL_HYPHEN_aXEL_SYMBOL_GREATERTHAN_IsASingleSymbol" ] ] - case Sem.run . Sem.runError $ parseSource Nothing input of + case Eff.runPureEff . Eff.runErrorNoCallStack $ parseSource Nothing input of Left err -> failSpec $ renderError err - Right x -> () <$ x `shouldBe` result + Right x -> void x `shouldBe` result + +hprop_can_parse_string_literals :: Property +hprop_can_parse_string_literals = + property $ do + string <- forAll $ Gen.string (Range.linear 0 5) Gen.unicode + let result = parseSingle $ showText string + result === LiteralString () string diff --git a/test/Axel/Test/SourcemapSpec.hs b/test/Axel/Test/SourcemapSpec.hs --- a/test/Axel/Test/SourcemapSpec.hs +++ b/test/Axel/Test/SourcemapSpec.hs @@ -6,9 +6,9 @@ import Data.Foldable -import Test.Tasty.Hspec +import Test.Hspec -spec_Sourcemap :: SpecWith () +spec_Sourcemap :: Spec spec_Sourcemap = do describe "findOriginalPosition" $ -- TODO Convert these into property tests do diff --git a/test/Axel/Test/Transpilation/TranspilationSpec.hs b/test/Axel/Test/Transpilation/TranspilationSpec.hs --- a/test/Axel/Test/Transpilation/TranspilationSpec.hs +++ b/test/Axel/Test/Transpilation/TranspilationSpec.hs @@ -24,43 +24,39 @@ import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified Polysemy as Sem -import qualified Polysemy.State as Sem +import qualified Effectful as Eff +import qualified Effectful.State.Static.Local as Eff import Test.Tasty import Test.Tasty.Golden -runApp :: Sem.Sem AppEffs a -> IO a +runApp :: Eff.Eff AppEffs a -> IO a runApp = - Sem.runM . + Eff.runEff . Effs.runTime . Effs.runRandom . Effs.runResource . Effs.runProcess . - Effs.runStackGhci . + Effs.runGhci . Effs.runFileSystem . - Effs.unsafeRunError Effs.renderError . Effs.runConsole . Effs.ignoreLog + Effs.runConsole . Effs.ignoreLog . Effs.unsafeRunError Effs.renderError test_transpilation_golden :: IO TestTree test_transpilation_golden = do axelFiles <- map (FilePath . T.pack) <$> - findByExtension [".axel_golden"] "test/Axel/Test/Transpilation" + findByExtension [".axel"] "test/Axel/Test/Transpilation" pure $ testGroup "transpilation golden tests" $ do axelFile <- axelFiles - let hsFile = replaceExtension axelFile "hs_golden" + let hsFile = replaceExtension axelFile "hs" let transpiled = do axelSource <- T.readFile $ T.unpack (op FilePath axelFile) output <- runApp $ - Sem.evalState (M.empty :: ModuleInfo) $ - Ghci.withStackGhci $ - transpileSource (takeBaseName axelFile) axelSource - let newSource = encodeUtf8Lazy $ SM.raw output - pure $ newSource <> "\n" + Eff.evalState (M.empty :: SM.ModuleInfo) $ + Ghci.withGhci $ transpileSource (takeBaseName axelFile) axelSource + pure $ encodeUtf8Lazy $ SM.raw output + let testName = T.unpack . op FilePath $ takeBaseName axelFile pure $ - goldenVsString - (T.unpack . op FilePath $ takeBaseName axelFile) - (T.unpack . op FilePath $ hsFile) - transpiled + goldenVsString testName (T.unpack . op FilePath $ hsFile) transpiled diff --git a/test/Axel/Test/Utils/ListSpec.hs b/test/Axel/Test/Utils/ListSpec.hs --- a/test/Axel/Test/Utils/ListSpec.hs +++ b/test/Axel/Test/Utils/ListSpec.hs @@ -5,15 +5,15 @@ import Axel.Utils.List -import Test.Tasty.Hspec +import Test.Hspec -spec_List :: SpecWith () +spec_List :: Spec spec_List = do describe "filterMapOut" $ do it "correctly partitions its input" $ do let f :: Int -> Maybe Text f n = - if n `mod` 2 == 0 + if even n then Just $ showText n else Nothing in filterMapOut f [1, 2, 3, 4, 6] `shouldBe` ([1, 3], ["2", "4", "6"]) diff --git a/test/Axel/Test/Utils/MaybeSpec.hs b/test/Axel/Test/Utils/MaybeSpec.hs --- a/test/Axel/Test/Utils/MaybeSpec.hs +++ b/test/Axel/Test/Utils/MaybeSpec.hs @@ -12,14 +12,14 @@ import Data.Generics.Uniplate.Zipper import qualified Data.Text as T -import Test.Tasty.Hspec +import Test.Hspec data MockAST = SExp [MockAST] | Symbol Text deriving (Data, Eq, Show) -spec_Maybe :: SpecWith () +spec_Maybe :: Spec spec_Maybe = do describe "foldUntilNothing" $ do it "works with basic function to be folded" $ do diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,12 +1,11 @@ {-# OPTIONS_GHC "-fno-warn-incomplete-patterns" #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} module TestUtils where import Axel.Prelude +import Axel.Eff ((:>>)) import Axel.Eff.Error import Axel.Parse import Axel.Sourcemap as SM @@ -14,32 +13,32 @@ import Control.Exception -import qualified Polysemy as Sem -import qualified Polysemy.Error as Sem -import qualified Polysemy.State as Sem - import Data.Functor.Identity (Identity) import qualified Data.Text as T +import qualified Effectful as Eff +import qualified Effectful.Error.Static as Eff +import qualified Effectful.State.Static.Local as Eff + import Hedgehog hiding (MonadGen) import qualified Hedgehog +import Test.Hspec import Test.Tasty.HUnit as HUnit -import Test.Tasty.Hspec throwInterpretError :: - forall s effs a. (Sem.Members '[ Sem.Error Text, Sem.State s] effs, Show s) + forall s effs a. ('[ Eff.Error Text, Eff.State s] :>> effs, Show s) => Text -> Text - -> Sem.Sem effs a + -> Eff.Eff effs a throwInterpretError actionName message = do errorMsg <- - Sem.gets $ \ctxt -> + Eff.gets $ \ctxt -> "\n----------\nACTION\t" <> actionName <> "\n\nMESSAGE\t" <> message <> "\n\nSTATE\t" <> showText ctxt <> "\n----------\n" - Sem.throw errorMsg + Eff.throwError errorMsg unwrapRight :: Renderer e -> Either e a -> a unwrapRight _ (Right x) = x @@ -58,17 +57,14 @@ Nothing -> "") -- | Will error at runtime if a parse error occurs. --- | If multiple expressions are able to be parsed, only the first will be returned. +-- If multiple expressions are able to be parsed, only the first will be returned. unsafeParseSingle :: Maybe FilePath -> Text -> SM.Expression unsafeParseSingle filePath = - head . Sem.run . unsafeRunError renderError . parseMultiple filePath + head . Eff.runPureEff . unsafeRunError renderError . parseMultiple filePath --- NOTE Workaround until https://github.com/hedgehogqa/haskell-hedgehog/commit/de401e949526951fdff87ef02fc75f13e8e22dfe --- is publicly released. --- TODO When hedgehogqa/haskell-hedgehog#303's changes are published, remove --- the `GenBase m ~ Identity` constraint (currently, it's only required --- because of `Gen.unicode`). --- | Use instead of `MonadGen` from `hedgehog`. +-- | A convenience wrapper for `MonadGen` from `hedgehog`. +-- We need the `GenBase m ~ Identity` constraint in order to use `Gen.filter`, +-- so it's convenient to always have it available. type MonadGen m = (Hedgehog.MonadGen m, GenBase m ~ Identity) failSpec :: Text -> Expectation