axel 0.0.12 → 0.0.13
raw patch · 75 files changed
+1716/−1709 lines, 75 filesdep +effectfuldep +effectful-coredep +effectful-plugindep −freer-simpledep −polysemydep −polysemy-plugindep ~aesondep ~ansi-terminaldep ~basesetup-changed
Dependencies added: effectful, effectful-core, effectful-plugin, effectful-th, hspec
Dependencies removed: freer-simple, polysemy, polysemy-plugin
Dependency ranges changed: aeson, ansi-terminal, base, bytestring, containers, directory, extra, filepath, ghcid, hashable, haskell-src-exts, hedgehog, hpack, lens, lens-aeson, megaparsec, mono-traversable, optparse-applicative, 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
Files
- README.org +10/−4
- Setup.hs +29/−1
- app/Main.hs +11/−10
- axel.cabal +220/−141
- resources/autogenerated/macros/AST.hs +0/−205
- resources/new-project-template/Setup.hs +0/−3
- resources/new-project-template/app/Main.hs +0/−4
- resources/new-project-template/src/Lib.hs +0/−3
- resources/new-project-template/test/Spec.hs +0/−2
- scripts/clean.sh +0/−8
- scripts/depDocs.sh +0/−3
- scripts/ghcid.sh +1/−1
- scripts/lint.sh +1/−1
- scripts/onHsFiles.sh +1/−1
- scripts/repl.sh +0/−1
- scripts/stackProfile.sh +0/−1
- scripts/test.sh +2/−1
- src/Axel.hs +21/−16
- src/Axel/AST.hs +84/−42
- src/Axel/Denormalize.hs +42/−18
- src/Axel/Eff.hs +18/−3
- src/Axel/Eff/App.hs +10/−9
- src/Axel/Eff/Console.hs +13/−14
- src/Axel/Eff/Error.hs +4/−8
- src/Axel/Eff/FileSystem.hs +41/−46
- src/Axel/Eff/Ghci.hs +28/−34
- src/Axel/Eff/Lens.hs +22/−36
- src/Axel/Eff/Log.hs +22/−18
- src/Axel/Eff/Loop.hs +9/−11
- src/Axel/Eff/Process.hs +33/−35
- src/Axel/Eff/Random.hs +9/−11
- src/Axel/Eff/Resource.hs +14/−14
- src/Axel/Eff/Restartable.hs +7/−10
- src/Axel/Eff/Time.hs +16/−16
- src/Axel/Eff/Unsafe.hs +4/−10
- src/Axel/Haskell/Cabal.hs +131/−0
- src/Axel/Haskell/Convert.hs +10/−62
- src/Axel/Haskell/File.hs +26/−29
- src/Axel/Haskell/Macros.hs +3/−2
- src/Axel/Haskell/Project.hs +33/−34
- src/Axel/Haskell/Stack.hs +0/−162
- src/Axel/Macros.hs +113/−102
- src/Axel/Normalize.hs +91/−100
- src/Axel/Parse.hs +21/−16
- src/Axel/Parse/AST.hs +48/−23
- src/Axel/Parse/Args.hs +6/−6
- src/Axel/Pretty.hs +27/−29
- src/Axel/Sourcemap.hs +37/−21
- src/Axel/Utils/Monad.hs +1/−1
- src/Axel/Utils/Recursion.hs +5/−2
- src/Axel/Utils/Text.hs +3/−8
- test/Axel/Test/ASTGen.hs +33/−18
- test/Axel/Test/DenormalizeSpec.hs +14/−12
- test/Axel/Test/Eff/AppMock.hs +14/−16
- test/Axel/Test/Eff/ConsoleMock.hs +11/−11
- test/Axel/Test/Eff/ConsoleSpec.hs +8/−6
- test/Axel/Test/Eff/FileSystemMock.hs +26/−29
- test/Axel/Test/Eff/FileSystemSpec.hs +16/−10
- test/Axel/Test/Eff/GhciMock.hs +10/−10
- test/Axel/Test/Eff/ProcessMock.hs +13/−12
- test/Axel/Test/Eff/ResourceMock.hs +7/−7
- test/Axel/Test/Eff/ResourceSpec.hs +8/−7
- test/Axel/Test/Haskell/CabalSpec.hs +157/−0
- test/Axel/Test/Haskell/ErrorSpec.hs +69/−0
- test/Axel/Test/Haskell/StackSpec.hs +0/−158
- test/Axel/Test/MacrosSpec.hs +2/−2
- test/Axel/Test/NormalizeSpec.hs +6/−6
- test/Axel/Test/Parse/ASTGen.hs +0/−2
- test/Axel/Test/Parse/ASTSpec.hs +16/−15
- test/Axel/Test/ParseSpec.hs +44/−7
- test/Axel/Test/SourcemapSpec.hs +2/−2
- test/Axel/Test/Transpilation/TranspilationSpec.hs +13/−17
- test/Axel/Test/Utils/ListSpec.hs +3/−3
- test/Axel/Test/Utils/MaybeSpec.hs +2/−2
- test/TestUtils.hs +15/−19
README.org view
@@ -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 -- <arguments>~ to run the project, and ~scripts/test.sh~ to test the project.+ Run ~cabal run -- axel <arguments>~ 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.
Setup.hs view
@@ -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"+ ]
app/Main.hs view
@@ -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))))
axel.cabal view
@@ -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
− resources/autogenerated/macros/AST.hs
@@ -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!"
− resources/new-project-template/Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple ( defaultMain )-main IO () = (() defaultMain)- where
− resources/new-project-template/app/Main.hs
@@ -1,4 +0,0 @@-module Main where-import Lib-main IO () = (() someFunc)- where
− resources/new-project-template/src/Lib.hs
@@ -1,3 +0,0 @@-module Lib where-someFunc IO () = (() (putStrLn "someFunc"))- where
− resources/new-project-template/test/Spec.hs
@@ -1,2 +0,0 @@-main IO () = (() (putStrLn "Test suite not yet implemented"))- where
− scripts/clean.sh
@@ -1,8 +0,0 @@-set -eu-set -o pipefail--echo "Cleaning autogenerated resources..."-rm -rf resources/autogenerated-echo "Autogenerated resources cleaned!"--stack clean
− scripts/depDocs.sh
@@ -1,3 +0,0 @@-#!/bin/sh--stack haddock --open --only-dependencies
scripts/ghcid.sh view
@@ -1,1 +1,1 @@-ghcid --command "stack repl axel:lib axel:test:axel-test --ghci-options=-fno-code"+ghcid --command "cabal repl -fno-code"
scripts/lint.sh view
@@ -1,1 +1,1 @@-./scripts/onHsFiles.sh hlint --color=always | grep -v 'No hints'+./scripts/onHsFiles.sh hlint --color=always --cross -j
scripts/onHsFiles.sh view
@@ -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 "$@"
− scripts/repl.sh
@@ -1,1 +0,0 @@-stack repl axel:lib axel:test:axel-test
− scripts/stackProfile.sh
@@ -1,1 +0,0 @@-stack --work-dir .stack-work-profile --profile "$@"
scripts/test.sh view
@@ -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 "$@"
src/Axel.hs view
@@ -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]
src/Axel/AST.hs view
@@ -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 <TypeDefinition> = ...@). 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
src/Axel/Denormalize.hs view
@@ -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) =
src/Axel/Eff.hs view
@@ -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)+
src/Axel/Eff/App.hs view
@@ -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
src/Axel/Eff/Console.hs view
@@ -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
src/Axel/Eff/Error.hs view
@@ -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
src/Axel/Eff/FileSystem.hs view
@@ -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
src/Axel/Eff/Ghci.hs view
@@ -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
src/Axel/Eff/Lens.hs view
@@ -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
src/Axel/Eff/Log.hs view
@@ -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")
src/Axel/Eff/Loop.hs view
@@ -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
src/Axel/Eff/Process.hs view
@@ -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
src/Axel/Eff/Random.hs view
@@ -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
src/Axel/Eff/Resource.hs view
@@ -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
src/Axel/Eff/Restartable.hs view
@@ -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'
src/Axel/Eff/Time.hs view
@@ -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
src/Axel/Eff/Unsafe.hs view
@@ -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
+ src/Axel/Haskell/Cabal.hs view
@@ -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]
src/Axel/Haskell/Convert.hs view
@@ -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 <> "`!")
src/Axel/Haskell/File.hs view
@@ -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 <> "..."
src/Axel/Haskell/Macros.hs view
@@ -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
src/Axel/Haskell/Project.hs view
@@ -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
− src/Axel/Haskell/Stack.hs
@@ -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]
src/Axel/Macros.hs view
@@ -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 -> "<unknown>"+ locationHint = maybe "<unknown>" renderSourcePosition originalAnn
src/Axel/Normalize.hs view
@@ -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
src/Axel/Parse.hs view
@@ -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
src/Axel/Parse/AST.hs view
@@ -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]
src/Axel/Parse/Args.hs view
@@ -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)))
src/Axel/Pretty.hs view
@@ -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
src/Axel/Sourcemap.hs view
@@ -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)
src/Axel/Utils/Monad.hs view
@@ -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
src/Axel/Utils/Recursion.hs view
@@ -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
src/Axel/Utils/Text.hs view
@@ -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 ""
test/Axel/Test/ASTGen.hs view
@@ -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 ]
test/Axel/Test/DenormalizeSpec.hs view
@@ -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))
test/Axel/Test/Eff/AppMock.hs view
@@ -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
test/Axel/Test/Eff/ConsoleMock.hs view
@@ -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)
test/Axel/Test/Eff/ConsoleSpec.hs view
@@ -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)
test/Axel/Test/Eff/FileSystemMock.hs view
@@ -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
test/Axel/Test/Eff/FileSystemSpec.hs view
@@ -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)
test/Axel/Test/Eff/GhciMock.hs view
@@ -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
test/Axel/Test/Eff/ProcessMock.hs view
@@ -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)
test/Axel/Test/Eff/ResourceMock.hs view
@@ -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)
test/Axel/Test/Eff/ResourceSpec.hs view
@@ -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)
+ test/Axel/Test/Haskell/CabalSpec.hs view
@@ -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)+-}
+ test/Axel/Test/Haskell/ErrorSpec.hs view
@@ -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
− test/Axel/Test/Haskell/StackSpec.hs
@@ -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)--}
test/Axel/Test/MacrosSpec.hs view
@@ -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
test/Axel/Test/NormalizeSpec.hs view
@@ -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)
test/Axel/Test/Parse/ASTGen.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GADTs #-}- module Axel.Test.Parse.ASTGen where import Axel.Prelude
test/Axel/Test/Parse/ASTSpec.hs view
@@ -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)
test/Axel/Test/ParseSpec.hs view
@@ -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
test/Axel/Test/SourcemapSpec.hs view
@@ -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
test/Axel/Test/Transpilation/TranspilationSpec.hs view
@@ -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
test/Axel/Test/Utils/ListSpec.hs view
@@ -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"])
test/Axel/Test/Utils/MaybeSpec.hs view
@@ -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
test/TestUtils.hs view
@@ -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