axel 0.0.9 → 0.0.11
raw patch · 98 files changed
+5419/−3041 lines, 98 filesdep +aesondep +ansi-terminaldep +hashabledep −parsecdep −regex-pcredep −strictdep ~bytestringdep ~containersdep ~directorynew-component:exe:axel
Dependencies added: aeson, ansi-terminal, hashable, hpack, megaparsec, mono-traversable, polysemy, polysemy-plugin, prettyprinter, profunctors, random, tasty-hunit, time, uniplate
Dependencies removed: parsec, regex-pcre, strict
Dependency ranges changed: bytestring, containers, directory, filepath, freer-simple, ghcid, haskell-src-exts, lens, lens-aeson, optparse-applicative, process, singletons, template-haskell, text, typed-process, vector, yaml
Files
- README.org +1/−1
- app/Main.hs +19/−33
- axel.cabal +162/−44
- resources/autogenerated/macros/AST.hs +167/−35
- resources/macros/MacroDefinitionAndEnvironmentFooter.hs +0/−2
- resources/macros/MacroDefinitionAndEnvironmentHeader.hs +0/−5
- resources/macros/Scaffold.hs +0/−12
- resources/new-project-template/Setup.axel +1/−1
- resources/new-project-template/Setup.hs +2/−2
- resources/new-project-template/app/Main.axel +3/−3
- resources/new-project-template/app/Main.hs +2/−2
- resources/new-project-template/src/Lib.axel +1/−1
- resources/new-project-template/src/Lib.hs +1/−1
- resources/new-project-template/test/Spec.axel +1/−1
- resources/new-project-template/test/Spec.hs +1/−1
- scripts/build.sh +8/−7
- scripts/depDocs.sh +3/−0
- scripts/format.sh +1/−1
- scripts/ghcid.sh +1/−1
- scripts/lint.sh +1/−1
- scripts/onHsFiles.sh +1/−0
- scripts/repl.sh +1/−0
- scripts/stackProfile.sh +1/−0
- scripts/test.sh +5/−2
- src/Axel.hs +35/−113
- src/Axel/AST.hs +489/−379
- src/Axel/Denormalize.hs +191/−110
- src/Axel/Eff.hs +7/−0
- src/Axel/Eff/App.hs +31/−0
- src/Axel/Eff/Console.hs +28/−17
- src/Axel/Eff/Error.hs +56/−0
- src/Axel/Eff/FileSystem.hs +64/−40
- src/Axel/Eff/Ghci.hs +53/−18
- src/Axel/Eff/Lens.hs +88/−0
- src/Axel/Eff/Log.hs +43/−0
- src/Axel/Eff/Loop.hs +23/−0
- src/Axel/Eff/Process.hs +46/−39
- src/Axel/Eff/Random.hs +24/−0
- src/Axel/Eff/Resource.hs +27/−33
- src/Axel/Eff/Restartable.hs +20/−0
- src/Axel/Eff/Time.hs +54/−0
- src/Axel/Eff/Unsafe.hs +15/−0
- src/Axel/Error.hs +0/−43
- src/Axel/Haskell/Convert.hs +660/−0
- src/Axel/Haskell/Converter.hs +0/−502
- src/Axel/Haskell/Error.hs +82/−0
- src/Axel/Haskell/File.hs +98/−100
- src/Axel/Haskell/Language.hs +46/−34
- src/Axel/Haskell/Macros.hs +9/−27
- src/Axel/Haskell/Prettify.hs +0/−14
- src/Axel/Haskell/Project.hs +79/−32
- src/Axel/Haskell/Stack.hs +84/−78
- src/Axel/Macros.hs +560/−272
- src/Axel/Normalize.hs +192/−134
- src/Axel/Parse.hs +142/−154
- src/Axel/Parse/AST.hs +162/−56
- src/Axel/Parse/Args.hs +21/−37
- src/Axel/Prelude.hs +44/−0
- src/Axel/Pretty.hs +106/−0
- src/Axel/Sourcemap.hs +184/−0
- src/Axel/Utils/Debug.hs +11/−6
- src/Axel/Utils/Display.hs +9/−43
- src/Axel/Utils/FilePath.hs +45/−0
- src/Axel/Utils/Foldable.hs +17/−0
- src/Axel/Utils/Json.hs +12/−0
- src/Axel/Utils/Lens.hs +0/−6
- src/Axel/Utils/List.hs +67/−1
- src/Axel/Utils/Maybe.hs +20/−0
- src/Axel/Utils/Monad.hs +6/−0
- src/Axel/Utils/Recursion.hs +43/−6
- src/Axel/Utils/String.hs +0/−22
- src/Axel/Utils/Text.hs +61/−0
- src/Axel/Utils/Tuple.hs +32/−0
- src/Axel/Utils/Zipper.hs +20/−0
- test/Axel/Test/ASTGen.hs +89/−66
- test/Axel/Test/DenormalizeSpec.hs +24/−10
- test/Axel/Test/Eff/AppMock.hs +63/−0
- test/Axel/Test/Eff/ConsoleMock.hs +22/−19
- test/Axel/Test/Eff/ConsoleSpec.hs +10/−4
- test/Axel/Test/Eff/FileSystemMock.hs +60/−61
- test/Axel/Test/Eff/FileSystemSpec.hs +53/−36
- test/Axel/Test/Eff/GhciMock.hs +20/−23
- test/Axel/Test/Eff/ProcessMock.hs +36/−52
- test/Axel/Test/Eff/ResourceMock.hs +8/−12
- test/Axel/Test/Eff/ResourceSpec.hs +18/−11
- test/Axel/Test/File/FileSpec.hs +0/−43
- test/Axel/Test/Haskell/StackSpec.hs +80/−72
- test/Axel/Test/MacrosSpec.hs +44/−0
- test/Axel/Test/MockUtils.hs +0/−30
- test/Axel/Test/NormalizeSpec.hs +14/−7
- test/Axel/Test/Parse/ASTGen.hs +13/−7
- test/Axel/Test/Parse/ASTSpec.hs +54/−0
- test/Axel/Test/ParseSpec.hs +75/−116
- test/Axel/Test/SourcemapSpec.hs +43/−0
- test/Axel/Test/Transpilation/TranspilationSpec.hs +65/−0
- test/Axel/Test/Utils/ListSpec.hs +19/−0
- test/Axel/Test/Utils/MaybeSpec.hs +45/−0
- test/TestUtils.hs +75/−0
README.org view
@@ -9,6 +9,6 @@ ** Code Style Use ~hindent~ to format code and ~hlint~ to catch errors. ** Running- Run ~scripts/build.sh~ to build the project, and ~stack exec axel-exe -- <arguments>~ to run ~app/Main.hs~. The executable takes as arguments either ~file <path to file>~ (which is the path of the Axel program to build and execute) or ~project~ (in which case an Axel project in the current directory will be built and executed).+ Run ~scripts/build.sh~ to build the project, and ~stack run <arguments>~ to run ~app/Main.hs~. The executable takes as arguments either ~file <path to file>~ (which is the path of the Axel program to build and execute) or ~project~ (in which case an Axel project in the current directory will be built and executed). ** Examples See the ~examples~ folder for example Axel programs.
app/Main.hs view
@@ -1,39 +1,25 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeApplications #-} module Main where-import Prelude hiding (putStrLn)+import qualified Prelude as GHCPrelude+import qualified Axel.Parse.AST as AST+import qualified Prelude as GHCPrelude+import qualified Axel.Parse.AST as AST+import Axel.Eff.App(AppEffs,runApp) import Axel.Eff.Console(putStrLn)-import qualified Axel.Eff.Console as Effs(Console)-import qualified Axel.Eff.Console as Console(runEff)-import qualified Axel.Eff.FileSystem as FS(runEff)-import qualified Axel.Eff.FileSystem as Effs(FileSystem)-import qualified Axel.Eff.Ghci as Ghci(runEff)-import qualified Axel.Eff.Ghci as Effs(Ghci)-import qualified Axel.Eff.Process as Proc(runEff)-import qualified Axel.Eff.Process as Effs(Process)-import qualified Axel.Eff.Resource as Res(runEff)-import qualified Axel.Eff.Resource as Effs(Resource)-import Axel.Error(Error)-import qualified Axel.Error as Error(runEff)-import Axel.Haskell.File(convertFile',transpileFile')-import Axel.Haskell.Project(buildProject,runProject)+import Axel.Eff.Ghci(withGhci)+import Axel.Haskell.File(convertFileInPlace,formatFileInPlace,transpileFileInPlace)+import Axel.Haskell.Project(buildProject,convertProject,formatProject,runProject) import Axel.Haskell.Stack(axelStackageVersion)-import Axel.Macros(ModuleInfo)-import Axel.Parse.Args(Command(Convert,File,Project,Version),commandParser)+import qualified Axel.Parse.AST as AST+import Axel.Parse.Args(Command(FileCommand,ProjectCommand,Version),FileCommand(ConvertFile,RunFile,FormatFile),ProjectCommand(ConvertProject,FormatProject,RunProject),commandParserInfo) import Control.Monad(void)-import Control.Monad.Freer(Eff)-import qualified Control.Monad.Freer as Effs(runM)-import qualified Control.Monad.Freer.Error as Effs(Error)-import Control.Monad.Freer.State(evalState) import qualified Data.Map as Map(empty)-import Options.Applicative((<**>),execParser,helper,info,progDesc)-type AppEffs = (Eff [Effs.Console,(Effs.Error Error),Effs.FileSystem,Effs.Ghci,Effs.Process,Effs.Resource,IO])-runApp :: (((->) (AppEffs a)) (IO a))-runApp = (((.) Effs.runM) (((.) Res.runEff) (((.) Proc.runEff) (((.) Ghci.runEff) (((.) FS.runEff) (((.) Error.runEff) Console.runEff)))))) where {}-app :: (((->) Command) (AppEffs ()))-app (Convert filePath) = ((($) void) (convertFile' filePath)) where {}-app (File filePath) = ((($) void) ((($) ((evalState @ModuleInfo) Map.empty)) (transpileFile' filePath))) where {}-app (Project ) = (((>>) buildProject) runProject) where {}-app (Version ) = ((($) putStrLn) (((<>) "Axel version ") axelStackageVersion)) where {}+import Options.Applicative(execParser)+import qualified Polysemy as Sem+import qualified Polysemy.State as Sem+import Prelude hiding (putStrLn)+app (FileCommand fileCommand) = (case fileCommand of {(ConvertFile filePath) -> (void (convertFileInPlace filePath));(FormatFile filePath) -> (formatFileInPlace filePath);(RunFile filePath) -> (void (Sem.evalState Map.empty (withGhci (transpileFileInPlace filePath))))})+app (ProjectCommand projectCommand) = (case projectCommand of {ConvertProject -> convertProject;FormatProject -> formatProject;RunProject -> ((>>) buildProject runProject)})+app (Version ) = (putStrLn ((<>) "Axel version " axelStackageVersion))+app :: (((->) Command) (Sem.Sem AppEffs ()))+main = ((>>=) (execParser commandParserInfo) (\modeCommand -> (runApp (app modeCommand)))) main :: (IO ())-main = do { modeCommand <- execParser $ info (commandParser <**> helper) (progDesc "The command to run."); runApp $ app modeCommand} where {}
axel.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.0.+-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: 1a1b9e269848a5390e4269df0118c7451807f8c073435b803ba49dea56a7fa28+-- hash: 3e7daf9876df4b7735920d7b3ecbfb5174adfc24b9d4245f3d0cbfbc17b2ee59 name: axel-version: 0.0.9+version: 0.0.11 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@@ -23,15 +23,16 @@ README.org scripts/build.sh 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/macros/MacroDefinitionAndEnvironmentFooter.hs- resources/macros/MacroDefinitionAndEnvironmentHeader.hs- resources/macros/Scaffold.hs resources/new-project-template/app/Main.axel resources/new-project-template/app/Main.hs resources/new-project-template/Setup.axel@@ -50,17 +51,26 @@ Axel Axel.AST Axel.Denormalize+ Axel.Eff+ Axel.Eff.App Axel.Eff.Console+ Axel.Eff.Error Axel.Eff.FileSystem Axel.Eff.Ghci+ Axel.Eff.Lens+ Axel.Eff.Log+ Axel.Eff.Loop Axel.Eff.Process+ Axel.Eff.Random Axel.Eff.Resource- Axel.Error- Axel.Haskell.Converter+ Axel.Eff.Restartable+ Axel.Eff.Time+ Axel.Eff.Unsafe+ Axel.Haskell.Convert+ Axel.Haskell.Error Axel.Haskell.File Axel.Haskell.Language Axel.Haskell.Macros- Axel.Haskell.Prettify Axel.Haskell.Project Axel.Haskell.Stack Axel.Macros@@ -68,55 +78,127 @@ Axel.Parse Axel.Parse.Args Axel.Parse.AST+ Axel.Prelude+ Axel.Pretty+ Axel.Sourcemap Axel.Utils.Debug Axel.Utils.Display+ Axel.Utils.FilePath+ Axel.Utils.Foldable Axel.Utils.Function- Axel.Utils.Lens+ Axel.Utils.Json Axel.Utils.List+ Axel.Utils.Maybe+ Axel.Utils.Monad Axel.Utils.Recursion- Axel.Utils.String+ Axel.Utils.Text+ Axel.Utils.Tuple+ Axel.Utils.Zipper other-modules: Paths_axel hs-source-dirs: src- ghc-options: -Wall -Wcpp-undef -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-simplifiable-class-constraints -Wmissing-import-lists+ 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+ build-tool-depends:+ hpack:hpack+ , tasty-discover:tasty-discover build-depends:- base >=4.12 && <4.13- , bytestring >=0.10.8- , containers >=0.6- , directory >=1.3- , filepath >=1.4.1- , freer-simple >=1.2.0.0- , ghcid >=0.7.1- , haskell-src-exts >=1.20.2- , lens >=4.16.1- , lens-aeson >=1.0.2- , optparse-applicative >=0.14.2- , parsec >=3.1.11- , process >=1.6.1- , regex-pcre >=0.94.4- , singletons >=2.4- , strict >=0.3.2- , template-haskell >=2.14- , text >=1.2.2- , typed-process >=0.2.2- , vector >=0.12.0- , yaml >=0.8.31+ aeson+ , ansi-terminal+ , base >=4.12 && <4.13+ , bytestring+ , containers+ , directory+ , 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+ , singletons+ , split+ , tasty+ , tasty-discover+ , tasty-golden+ , tasty-hedgehog+ , tasty-hspec+ , tasty-hunit+ , template-haskell+ , text+ , time+ , transformers+ , typed-process+ , uniplate+ , vector+ , yaml default-language: Haskell2010 -executable axel-exe+executable axel main-is: Main.hs other-modules: Paths_axel hs-source-dirs: app- ghc-options: -Wall -Wcpp-undef -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-simplifiable-class-constraints -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists+ 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+ build-tool-depends:+ hpack:hpack+ , tasty-discover:tasty-discover build-depends:- axel+ aeson+ , ansi-terminal+ , axel , base >=4.12 && <4.13- , containers >=0.6- , freer-simple >=1.2.0.0- , optparse-applicative >=0.14.2+ , bytestring+ , containers+ , directory+ , 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+ , singletons+ , split+ , tasty+ , tasty-discover+ , tasty-golden+ , tasty-hedgehog+ , tasty-hspec+ , tasty-hunit+ , template-haskell+ , text+ , time+ , transformers+ , typed-process+ , uniplate+ , vector+ , yaml default-language: Haskell2010 test-suite axel-test@@ -125,6 +207,7 @@ other-modules: Axel.Test.ASTGen Axel.Test.DenormalizeSpec+ Axel.Test.Eff.AppMock Axel.Test.Eff.ConsoleMock Axel.Test.Eff.ConsoleSpec Axel.Test.Eff.FileSystemMock@@ -133,30 +216,65 @@ Axel.Test.Eff.ProcessMock Axel.Test.Eff.ResourceMock Axel.Test.Eff.ResourceSpec- Axel.Test.File.FileSpec Axel.Test.Haskell.StackSpec- Axel.Test.MockUtils+ Axel.Test.MacrosSpec Axel.Test.NormalizeSpec Axel.Test.Parse.ASTGen+ Axel.Test.Parse.ASTSpec Axel.Test.ParseSpec+ Axel.Test.SourcemapSpec+ Axel.Test.Transpilation.TranspilationSpec+ Axel.Test.Utils.ListSpec+ Axel.Test.Utils.MaybeSpec+ TestUtils Paths_axel hs-source-dirs: test- ghc-options: -Wall -Wcpp-undef -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-simplifiable-class-constraints -threaded -rtsopts -with-rtsopts=-N+ 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+ build-tool-depends:+ hpack:hpack+ , tasty-discover:tasty-discover build-depends:- axel+ aeson+ , ansi-terminal+ , axel , base >=4.12 && <4.13 , bytestring , containers+ , directory , filepath- , freer-simple >=1.2.0.0+ , freer-simple+ , ghcid+ , hashable+ , haskell-src-exts , hedgehog+ , hpack , lens+ , lens-aeson+ , megaparsec+ , mono-traversable+ , optparse-applicative+ , polysemy+ , polysemy-plugin+ , prettyprinter+ , process+ , profunctors+ , random+ , singletons , split , tasty , tasty-discover , tasty-golden , tasty-hedgehog , tasty-hspec+ , tasty-hunit+ , template-haskell+ , text+ , time , transformers+ , typed-process+ , uniplate+ , vector+ , yaml default-language: Haskell2010
resources/autogenerated/macros/AST.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# 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`).@@ -8,66 +10,196 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef) import Data.Semigroup ((<>))-import Data.Typeable (Typeable) import System.IO.Unsafe (unsafePerformIO) +handleStringEscapes :: String -> String+handleStringEscapes =+ concatMap $ \case+ '\\' -> "\\\\"+ c -> [c]++-- ******************************+-- ** AST **+-- ****************************** -- TODO `Expression` should probably be `Traversable`, use recursion schemes, etc.--- I should provide `toFix` and `fromFix` functions for macros to take advantage of.+-- 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- = LiteralChar Char- | LiteralInt Int- | LiteralString String- | SExpression [Expression]- | Symbol String- deriving (Eq, Show, Typeable)+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+ -- ******************************--- Internal utilities+-- ** Sourcemap ** -- ******************************-toAxel :: Expression -> String-toAxel (LiteralChar x) = ['{', x, '}']-toAxel (LiteralInt x) = show x-toAxel (LiteralString xs) = "\"" <> xs <> "\""-toAxel (SExpression xs) = "(" <> unwords (map toAxel xs) <> ")"-toAxel (Symbol x) = x+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)+ -- ******************************--- Macro definition utilities+-- ** 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+gensym :: IO (Expression SourceMetadata) gensym = do suffix <- readIORef gensymCounter let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" <> show suffix modifyIORef gensymCounter succ- pure $ Symbol identifier+ pure $ Symbol Nothing identifier --- | This allows splice-unquoting of both `[Expression]`s and `SExpression`s, without requiring special syntax for each.+-- | This allows splice-unquoting of both `[Expression]`s and `SExpression`s,+-- without requiring special syntax for each. class ToExpressionList a where- toExpressionList :: a -> [Expression]+ type Annotation a+ toExpressionList :: a -> [Expression (Annotation a)] -instance ToExpressionList [Expression] where- toExpressionList :: [Expression] -> [Expression]+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 where- toExpressionList :: Expression -> [Expression]- toExpressionList (SExpression xs) = xs+-- | 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- (show x <>+ (toAxel x <> " cannot be splice-unquoted, because it is not an s-expression!") -programToTopLevelExpressions :: Expression -> [Expression]-programToTopLevelExpressions (SExpression (Symbol "begin":stmts)) = stmts-programToTopLevelExpressions _ =- error "programToTopLevelExpressions must be passed a top-level program!"+wrapCompoundExpressions ::+ [Expression SourceMetadata] -> Expression SourceMetadata+wrapCompoundExpressions stmts =+ SExpression Nothing (Symbol Nothing "begin" : stmts) -topLevelExpressionsToProgram :: [Expression] -> Expression-topLevelExpressionsToProgram stmts = SExpression (Symbol "begin" : stmts)+unwrapCompoundExpressions :: Expression ann -> [Expression ann]+unwrapCompoundExpressions (SExpression _ (Symbol _ "begin":stmts)) = stmts+unwrapCompoundExpressions _ =+ error "unwrapCompoundExpressions must be passed a top-level program!"
@@ -1,2 +0,0 @@-main_AXEL_AUTOGENERATED_FUNCTION_DEFINITION :: [AST_AXEL_AUTOGENERATED_IMPORT.Expression] -> IO [AST_AXEL_AUTOGENERATED_IMPORT.Expression]-main_AXEL_AUTOGENERATED_FUNCTION_DEFINITION args = map Unsafe.Coerce_AXEL_AUTOGENERATED_IMPORT.unsafeCoerce <$> %%%MACRO_NAME%%% (map Unsafe.Coerce_AXEL_AUTOGENERATED_IMPORT.unsafeCoerce args)
− resources/macros/MacroDefinitionAndEnvironmentHeader.hs
@@ -1,5 +0,0 @@-module AutogeneratedAxelMacroDefinitionAndEnvironment where--import qualified Axel.Parse.AST as AST_AXEL_AUTOGENERATED_IMPORT--import qualified Unsafe.Coerce as Unsafe.Coerce_AXEL_AUTOGENERATED_IMPORT
− resources/macros/Scaffold.hs
@@ -1,12 +0,0 @@-module AutogeneratedAxelScaffold where--import qualified AutogeneratedAxelMacroDefinitionAndEnvironment-import Axel.Parse.AST--import Unsafe.Coerce (unsafeCoerce)--main :: IO ()-main = do- result <-- AutogeneratedAxelMacroDefinitionAndEnvironment.main_AXEL_AUTOGENERATED_FUNCTION_DEFINITION (map unsafeCoerce %%%ARGUMENTS%%%)- putStrLn $ unlines $ map toAxel result
resources/new-project-template/Setup.axel view
@@ -1,4 +1,4 @@ (import Distribution.Simple (defaultMain)) -(= main (IO Unit)+(def main (IO Unit) (() defaultMain))
resources/new-project-template/Setup.hs view
@@ -1,3 +1,3 @@-import Distribution.Simple (defaultMain)+import Distribution.Simple ( defaultMain ) main IO () = (() defaultMain)- where+ where
resources/new-project-template/app/Main.axel view
@@ -1,6 +1,6 @@ (module Main) -(importUnrestricted Lib)+(import Lib all) -(= main (IO Unit)- (() someFunc))+(def main (IO Unit)+ (() someFunc))
resources/new-project-template/app/Main.hs view
@@ -1,4 +1,4 @@ module Main where-import Lib+import Lib main IO () = (() someFunc)- where+ where
resources/new-project-template/src/Lib.axel view
@@ -1,4 +1,4 @@ (module Lib) -(= someFunc (IO Unit)+(def someFunc (IO Unit) (() (putStrLn "someFunc")))
resources/new-project-template/src/Lib.hs view
@@ -1,3 +1,3 @@ module Lib where someFunc IO () = (() (putStrLn "someFunc"))- where+ where
resources/new-project-template/test/Spec.axel view
@@ -1,2 +1,2 @@-(= main (IO Unit)+(def main (IO Unit) (() (putStrLn "Test suite not yet implemented")))
resources/new-project-template/test/Spec.hs view
@@ -1,2 +1,2 @@ main IO () = (() (putStrLn "Test suite not yet implemented"))- where+ where
scripts/build.sh view
@@ -1,11 +1,12 @@ set -eu set -o pipefail -echo "Copying macro header..."-mkdir -p resources/autogenerated/macros-cp src/Axel/Parse/AST.hs resources/autogenerated/macros/AST.hs-echo "Macro header copied!"+echo "[WIP] Transpile *.axel files..."+# If we run this in the context of the current project, Cabal will try to globally symlink the local package (which is not what we want).+cd ~+cabal new-install axel --overwrite-policy=always+cd -+axel-exe project+echo "[WIP] *.axel files transpiled!\n" -stack build --fast-stack exec axel-exe -- project-stack build --fast+stack build --ghc-options "-g"
+ scripts/depDocs.sh view
@@ -0,0 +1,3 @@+#!/bin/sh++stack haddock --open --only-dependencies
scripts/format.sh view
@@ -1,1 +1,1 @@-find app src test -type f | grep -e '^.*\.hs$' | grep -v 'src/Axel/Parse/Args.hs' | grep -v 'src/Axel.hs' | grep -v 'src/Axel/Haskell/Macros.hs' | xargs -L 1 hindent+./scripts/onHsFiles.sh hindent
scripts/ghcid.sh view
@@ -1,1 +1,1 @@-ghcid -c "stack ghci axel"+ghcid --command "stack repl axel:lib axel:test:axel-test --ghci-options=-fno-code"
scripts/lint.sh view
@@ -1,1 +1,1 @@-find app src test -type f | grep '^.*\.hs$' | grep -v 'src/Axel/Parse/Args.hs' | grep -v 'src/Axel.hs' | grep -v 'src/Axel/Haskell/Macros.hs' | xargs -L 1 hlint --color=always | grep -v 'No hints'+./scripts/onHsFiles.sh hlint --color=always | grep -v 'No hints'
+ scripts/onHsFiles.sh view
@@ -0,0 +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 $@
+ scripts/repl.sh view
@@ -0,0 +1,1 @@+stack repl axel:lib axel:test:axel-test
+ scripts/stackProfile.sh view
@@ -0,0 +1,1 @@+stack --work-dir .stack-work-profile --profile "$@"
scripts/test.sh view
@@ -1,5 +1,8 @@ set -eu set -o pipefail -./scripts/build.sh-stack test+# Sometimes, when macro expansion tests are run, `ghc` will stay alive+# and consume ridiculous amounts of memory and CPU.+trap "killall axel-test ghc" EXIT++stack test --fast --ghc-options "-g" --test-arguments "--hide-successes" "$@"
src/Axel.hs view
@@ -1,115 +1,37 @@+{-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Axel where+import qualified Prelude as GHCPrelude import qualified Axel.Parse.AST as AST-import Control.Lens.Cons (snoc)-mdo' ((:) var ((:) (AST.Symbol "<-") ((:) val rest)))- = (AST.SExpression- (concat- [[(AST.Symbol ">>=")], [val],- [(AST.SExpression- (concat- [[(AST.Symbol "\\")], [(AST.SExpression (concat [[var]]))],- [(mdo' rest)]]))]]))- where-mdo' ((:) val rest)- = (case rest of- [] -> val- _ -> (AST.SExpression- (concat [[(AST.Symbol ">>")], [val], [(mdo' rest)]])))- where--mdo' :: ((->) [AST.Expression] AST.Expression)-quasiquote_AXEL_AUTOGENERATED_MACRO_DEFINITION- [(AST.SExpression xs)]- = (let quasiquoteElem- = (\ x ->- (case x of- (AST.SExpression [(AST.Symbol "unquote"), x]) -> (AST.SExpression- [(AST.Symbol "list"), x])- (AST.SExpression- [(AST.Symbol "unquoteSplicing"), x]) -> (AST.SExpression- [(AST.Symbol- "AST.toExpressionList"),- x])- atom -> (AST.SExpression- [(AST.Symbol "list"),- (AST.SExpression [(AST.Symbol "quasiquote"), atom])])))- in- (pure- [(AST.SExpression- [(AST.Symbol "AST.SExpression"),- (AST.SExpression- [(AST.Symbol "concat"),- (AST.SExpression- ((:) (AST.Symbol "list") (map quasiquoteElem xs)))])])]))- where-quasiquote_AXEL_AUTOGENERATED_MACRO_DEFINITION [atom]- = (pure [(AST.SExpression [(AST.Symbol "quote"), atom])])- where-applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION [x, op, y]- = (pure [(AST.SExpression (concat [[op], [x], [y]]))])- where-defmacro_AXEL_AUTOGENERATED_MACRO_DEFINITION ((:) name cases)- = (pure- (map- (\ x ->- (AST.SExpression- (concat- [[(AST.Symbol "=macro")], [name], (AST.toExpressionList x)])))- cases))- where-def_AXEL_AUTOGENERATED_MACRO_DEFINITION- ((:) name ((:) typeSig cases))- = (pure- (snoc- (map- (\ x ->- (AST.SExpression- (concat [[(AST.Symbol "=")], [name], (AST.toExpressionList x)])))- cases)- (AST.SExpression- (concat [[(AST.Symbol "::")], [name], [typeSig]]))))- where-fnCase_AXEL_AUTOGENERATED_MACRO_DEFINITION cases- = ((<$>)- (\ varId ->- [(AST.SExpression- (concat- [[(AST.Symbol "\\")], [(AST.SExpression (concat [[varId]]))],- [(AST.SExpression- (concat- [[(AST.Symbol "case")], [varId],- (AST.toExpressionList cases)]))]]))])- AST.gensym)- where-mdo_AXEL_AUTOGENERATED_MACRO_DEFINITION input- = (pure [(mdo' input)])- where-if_AXEL_AUTOGENERATED_MACRO_DEFINITION [cond, true, false]- = (pure- [(AST.SExpression- (concat- [[(AST.Symbol "case")], [cond],- [(AST.SExpression (concat [[(AST.Symbol "True")], [true]]))],- [(AST.SExpression (concat [[(AST.Symbol "False")], [false]]))]]))])- where--quasiquote_AXEL_AUTOGENERATED_MACRO_DEFINITION ::- ((->) ([] AST.Expression) (IO ([] AST.Expression)))--applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION ::- ((->) ([] AST.Expression) (IO ([] AST.Expression)))--defmacro_AXEL_AUTOGENERATED_MACRO_DEFINITION ::- ((->) ([] AST.Expression) (IO ([] AST.Expression)))--def_AXEL_AUTOGENERATED_MACRO_DEFINITION ::- ((->) ([] AST.Expression) (IO ([] AST.Expression)))--fnCase_AXEL_AUTOGENERATED_MACRO_DEFINITION ::- ((->) ([] AST.Expression) (IO ([] AST.Expression)))--mdo_AXEL_AUTOGENERATED_MACRO_DEFINITION ::- ((->) ([] AST.Expression) (IO ([] AST.Expression)))--if_AXEL_AUTOGENERATED_MACRO_DEFINITION ::- ((->) ([] AST.Expression) (IO ([] AST.Expression)))+import Axel.Prelude+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)+import qualified Data.Text as T+import System.IO.Unsafe(unsafePerformIO)+import Control.Lens.Cons(snoc)+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/8056614292560291696/result.axel" (SM.Position 1 157))) ">>=")],[val],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 45 18))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/8056614292560291696/result.axel" (SM.Position 1 255))) "\\")],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 45 21))) (concat [[var]]))],[(expandDo' rest)]]))]]))+expandDo' ((:) (AST.SExpression _ ((:) (AST.Symbol _ "let") bindings)) rest) = (AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 47 8))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/8056614292560291696/result.axel" (SM.Position 2 161))) "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/8056614292560291696/result.axel" (SM.Position 3 138))) ">>")],[val],[(expandDo' rest)]]))})+expandDo' :: ((->) ([] SM.Expression) SM.Expression)+gensymCounter = (unsafePerformIO (newIORef 0))+gensymCounter :: (IORef Int)+{-# NOINLINE gensymCounter #-}+gensym = ((>>=) (readIORef gensymCounter) (\suffix -> (let {identifier = ((<>) "aXEL_AUTOGENERATED_IDENTIFIER_" (showText suffix))} in ((>>) (modifyIORef gensymCounter succ) (pure (AST.Symbol Nothing (T.unpack identifier)))))))+gensym :: (IO SM.Expression)+isPrelude = ((.) ((==) (FilePath "Axel.axel")) takeFileName)+isPrelude :: ((->) FilePath Bool)+preludeMacros = ["applyInfix","defmacro","def","do'","\\case","syntaxQuote"]+preludeMacros :: ([] Text)+applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION [x,op,y] = (pure [(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 19 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 24 55))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 28 17))) "=macro")],[name],[(AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 24 69))) (concat [[args]]))],(AST.toExpressionList body)]))) cases))+def_AXEL_AUTOGENERATED_MACRO_DEFINITION ((:) name ((:) typeSig cases)) = (pure (snoc (map (\x -> (AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 32 32))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/3023196837319215740/result.axel" (SM.Position 1 152))) "=")],[name],(AST.toExpressionList x)]))) cases) (AST.SExpression (GHCPrelude.Just ((,) "src/Axel.axel" (SM.Position 34 20))) (concat [[(AST.Symbol (GHCPrelude.Just ((,) "axelTemp/3023196837319215740/result.axel" (SM.Position 1 284))) "::")],[name],[typeSig]]))))+syntaxQuote_AXEL_AUTOGENERATED_MACRO_DEFINITION [x] = (pure [(AST.quoteExpression (const (AST.Symbol Nothing "_")) x)])+do'_AXEL_AUTOGENERATED_MACRO_DEFINITION input = (pure [(expandDo' input)])+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/8873645910751190435/result.axel" (SM.Position 1 127))) "\\")],[(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/8873645910751190435/result.axel" (SM.Position 1 314))) "case")],[varId],(AST.toExpressionList cases)]))]]))]) gensym)+applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> IO [AST.Expression SM.SourceMetadata]+defmacro_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> IO [AST.Expression SM.SourceMetadata]+def_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> IO [AST.Expression SM.SourceMetadata]+syntaxQuote_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> IO [AST.Expression SM.SourceMetadata]+do'_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> IO [AST.Expression SM.SourceMetadata]+aXEL_SYMBOL_BACKSLASH_case_AXEL_AUTOGENERATED_MACRO_DEFINITION :: [AST.Expression SM.SourceMetadata] -> IO [AST.Expression SM.SourceMetadata]
src/Axel/AST.hs view
@@ -1,262 +1,271 @@ {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-} module Axel.AST where +import Axel.Prelude+ import Axel.Haskell.Language (isOperator) import Axel.Haskell.Macros (hygenisizeMacroName)-import Axel.Utils.Display+import qualified Axel.Parse.AST as Parse+ ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,+ Symbol)+ )+import Axel.Sourcemap ( Bracket(CurlyBraces, DoubleQuotes, Parentheses, SingleQuotes, SquareBrackets) , Delimiter(Commas, Newlines, Pipes, Spaces)+ )+import qualified Axel.Sourcemap as SM+ ( Expression+ , Output(Output)+ , SourceMetadata , delimit , renderBlock- , renderPragma , surround )-import Axel.Utils.Recursion (Recursive(bottomUpFmap, bottomUpTraverse))+import qualified Axel.Utils.Display as Display (delimit, renderPragma, surround)+import Axel.Utils.Text (handleCharEscapes)+import Axel.Utils.Tuple (annotate, unannotated) -import Control.Arrow ((***))+import Control.Lens.Combinators (_head, _last) import Control.Lens.Operators ((%~), (^.)) import Control.Lens.TH (makeFieldsNoPrefix, makePrisms)+import Control.Lens.Wrapped (_Wrapped)+import Control.Monad ((>=>)) -import Data.Function ((&))+import Data.Data (Data) import Data.Semigroup ((<>))+import qualified Data.Text as T class ToHaskell a where- toHaskell :: a -> String--type Identifier = String--data CaseBlock = CaseBlock- { _expr :: Expression- , _matches :: [(Expression, Expression)]- } deriving (Eq, Show)--data FunctionApplication = FunctionApplication- { _function :: Expression- , _arguments :: [Expression]- } deriving (Eq, Show)--data IfBlock = IfBlock- { _cond :: Expression- , _ifTrue :: Expression- , _ifFalse :: Expression- } deriving (Eq, Show)--newtype TopLevel = TopLevel- { _statements :: [Statement]- } deriving (Eq, Show)+ toHaskell :: a -> SM.Output -data TypeDefinition- = ProperType Identifier- | TypeConstructor FunctionApplication- deriving (Eq, Show)+type Identifier = Text -instance ToHaskell TypeDefinition where- toHaskell :: TypeDefinition -> String- toHaskell (ProperType x) = x- toHaskell (TypeConstructor x) = toHaskell x+data CaseBlock ann =+ CaseBlock+ { _ann :: ann+ , _expr :: Expression ann+ , _matches :: [(Expression ann, Expression ann)]+ }+ deriving (Data, Eq, Functor, Show) -data DataDeclaration = DataDeclaration- { _typeDefinition :: TypeDefinition- , _constructors :: [FunctionApplication]- } deriving (Eq, Show)+data FunctionApplication ann =+ FunctionApplication+ { _ann :: ann+ , _function :: Expression ann+ , _arguments :: [Expression ann]+ }+ deriving (Data, Eq, Functor, Show) -data NewtypeDeclaration = NewtypeDeclaration- { _typeDefinition :: TypeDefinition- , _constructor :: FunctionApplication- } deriving (Eq, Show)+data IfBlock ann =+ IfBlock+ { _ann :: ann+ , _cond :: Expression ann+ , _ifTrue :: Expression ann+ , _ifFalse :: Expression ann+ }+ deriving (Data, Eq, Functor, Show) -data FunctionDefinition = FunctionDefinition- { _name :: Identifier- , _arguments :: [Expression]- , _body :: Expression- , _whereBindings :: [FunctionDefinition]- } deriving (Eq, Show)+data TopLevel ann =+ TopLevel+ { _ann :: ann+ , _statements :: [Statement ann]+ }+ deriving (Data, Eq, Functor, Show) -data Import- = ImportItem Identifier- | ImportType Identifier- [Identifier]- deriving (Eq, Show)+data TypeDefinition ann+ = ProperType ann Identifier+ | TypeConstructor ann (FunctionApplication ann)+ deriving (Data, Eq, Functor, Show) -instance ToHaskell Import where- toHaskell :: Import -> String- toHaskell (ImportItem x) =- if isOperator x- then surround Parentheses x- else x- toHaskell (ImportType typeName imports) =- typeName <> surround Parentheses (delimit Commas imports)+data DataDeclaration ann =+ DataDeclaration+ { _ann :: ann+ , _typeDefinition :: TypeDefinition ann+ , _constructors :: [FunctionApplication ann]+ }+ deriving (Data, Eq, Functor, Show) -data ImportSpecification- = ImportAll- | ImportOnly [Import]- deriving (Eq, Show)+data NewtypeDeclaration ann =+ NewtypeDeclaration+ { _ann :: ann+ , _typeDefinition :: TypeDefinition ann+ , _constructor :: FunctionApplication ann+ }+ deriving (Data, Eq, Functor, Show) -instance ToHaskell ImportSpecification where- toHaskell :: ImportSpecification -> String- toHaskell ImportAll = ""- toHaskell (ImportOnly importList) =- surround Parentheses $ delimit Commas $ map toHaskell importList+data FunctionDefinition ann =+ FunctionDefinition+ { _ann :: ann+ , _name :: Identifier+ , _arguments :: [Expression ann]+ , _body :: Expression ann+ , _whereBindings :: [FunctionDefinition ann]+ }+ deriving (Data, Eq, Functor, Show) -data Lambda = Lambda- { _arguments :: [Expression]- , _body :: Expression- } deriving (Eq, Show)+data Import ann+ = ImportItem ann Identifier+ | ImportType ann Identifier [Identifier]+ deriving (Data, Eq, Functor, Show) -data LetBlock = LetBlock- { _bindings :: [(Expression, Expression)]- , _body :: Expression- } deriving (Eq, Show)+data ImportSpecification ann+ = ImportAll ann+ | ImportOnly ann [Import ann]+ deriving (Data, Eq, Functor, Show) -newtype MacroDefinition = MacroDefinition- { _functionDefinition :: FunctionDefinition- } deriving (Eq, Show)+data Lambda ann =+ Lambda+ { _ann :: ann+ , _arguments :: [Expression ann]+ , _body :: Expression ann+ }+ deriving (Data, Eq, Functor, Show) -data MacroImport = MacroImport- { _moduleName :: Identifier- , _imports :: [Identifier]- } deriving (Eq, Show)+data LetBlock ann =+ LetBlock+ { _ann :: ann+ , _bindings :: [(Expression ann, Expression ann)]+ , _body :: Expression ann+ }+ deriving (Data, Eq, Functor, Show) -newtype Pragma = Pragma- { _pragmaSpecification :: String- } deriving (Eq, Show)+data MacroDefinition ann =+ MacroDefinition+ { _ann :: ann+ , _functionDefinition :: FunctionDefinition ann+ }+ deriving (Data, Eq, Functor, Show) -data QualifiedImport = QualifiedImport- { _moduleName :: Identifier- , _alias :: Identifier- , _imports :: ImportSpecification- } deriving (Eq, Show)+data MacroImport ann =+ MacroImport+ { _ann :: ann+ , _moduleName :: Identifier+ , _imports :: [Identifier]+ }+ deriving (Data, Eq, Functor, Show) -newtype RecordDefinition = RecordDefinition- { _bindings :: [(Identifier, Expression)]- } deriving (Eq, Show)+data Pragma ann =+ Pragma+ { _ann :: ann+ , _pragmaSpecification :: Text+ }+ deriving (Data, Eq, Functor, Show) -newtype RecordType = RecordType- { _fields :: [(Identifier, Expression)]- } deriving (Eq, Show)+data QualifiedImport ann =+ QualifiedImport+ { _ann :: ann+ , _moduleName :: Identifier+ , _alias :: Identifier+ , _imports :: ImportSpecification ann+ }+ deriving (Data, Eq, Functor, Show) -data RestrictedImport = RestrictedImport- { _moduleName :: Identifier- , _imports :: ImportSpecification- } deriving (Eq, Show)+data RecordDefinition ann =+ RecordDefinition+ { _ann :: ann+ , _bindings :: [(Identifier, Expression ann)]+ }+ deriving (Data, Eq, Functor, Show) -data TypeclassDefinition = TypeclassDefinition- { _name :: Expression- , _constraints :: [Expression]- , _signatures :: [TypeSignature]- } deriving (Eq, Show)+data RecordType ann =+ RecordType+ { _ann :: ann+ , _fields :: [(Identifier, Expression ann)]+ }+ deriving (Data, Eq, Functor, Show) -data TypeclassInstance = TypeclassInstance- { _instanceName :: Expression- , _definitions :: [FunctionDefinition]- } deriving (Eq, Show)+data RestrictedImport ann =+ RestrictedImport+ { _ann :: ann+ , _moduleName :: Identifier+ , _imports :: ImportSpecification ann+ }+ deriving (Data, Eq, Functor, Show) -data TypeSignature = TypeSignature- { _name :: Identifier- , _typeDefinition :: Expression- } deriving (Eq, Show)+data TypeclassDefinition ann =+ TypeclassDefinition+ { _ann :: ann+ , _name :: Expression ann+ , _constraints :: [Expression ann]+ , _signatures :: [TypeSignature ann]+ }+ deriving (Data, Eq, Functor, Show) -data TypeSynonym = TypeSynonym- { _alias :: Expression- , _definition :: Expression- } deriving (Eq, Show)+data TypeclassInstance ann =+ TypeclassInstance+ { _ann :: ann+ , _instanceName :: Expression ann+ , _definitions :: [FunctionDefinition ann]+ }+ deriving (Data, Eq, Functor, Show) -data Expression- = ECaseBlock CaseBlock- | EEmptySExpression- | EFunctionApplication FunctionApplication- | EIdentifier Identifier- | EIfBlock IfBlock- | ELambda Lambda- | ELetBlock LetBlock- | ELiteral Literal- | ERawExpression String- | ERecordDefinition RecordDefinition- | ERecordType RecordType- deriving (Eq, Show)+data TypeSignature ann =+ TypeSignature+ { _ann :: ann+ , _name :: Identifier+ , _typeDefinition :: Expression ann+ }+ deriving (Data, Eq, Functor, Show) -instance ToHaskell Expression where- toHaskell :: Expression -> String- toHaskell (ECaseBlock x) = toHaskell x- toHaskell EEmptySExpression = "()"- toHaskell (EFunctionApplication x) = toHaskell x- toHaskell (EIdentifier x) =- if isOperator x- then surround Parentheses x- else x- toHaskell (EIfBlock x) = toHaskell x- toHaskell (ELambda x) = toHaskell x- toHaskell (ELetBlock x) = toHaskell x- toHaskell (ELiteral x) = toHaskell x- toHaskell (ERawExpression x) = x- toHaskell (ERecordDefinition x) = toHaskell x- toHaskell (ERecordType x) = toHaskell x+data TypeSynonym ann =+ TypeSynonym+ { _ann :: ann+ , _alias :: Expression ann+ , _definition :: Expression ann+ }+ deriving (Data, Eq, Functor, Show) -data Literal- = LChar Char- | LInt Int- | LString String- deriving (Eq, Show)+data Expression ann+ = ECaseBlock (CaseBlock ann)+ | EEmptySExpression ann+ | EFunctionApplication (FunctionApplication ann)+ | EIdentifier ann Identifier+ | EIfBlock (IfBlock ann)+ | ELambda (Lambda ann)+ | ELetBlock (LetBlock ann)+ | ELiteral (Literal ann)+ | ERawExpression ann Text+ | ERecordDefinition (RecordDefinition ann)+ | ERecordType (RecordType ann)+ deriving (Data, Eq, Functor, Show) -instance ToHaskell Literal where- toHaskell :: Literal -> String- toHaskell (LChar x) = surround SingleQuotes [x]- toHaskell (LInt x) = show x- toHaskell (LString x) = surround DoubleQuotes x+data Literal ann+ = LChar ann Char+ | LInt ann Int+ | LString ann Text+ deriving (Data, Eq, Functor, Show) -data Statement- = SDataDeclaration DataDeclaration- | SFunctionDefinition FunctionDefinition- | SMacroDefinition MacroDefinition- | SMacroImport MacroImport- | SModuleDeclaration Identifier- | SNewtypeDeclaration NewtypeDeclaration- | SPragma Pragma- | SQualifiedImport QualifiedImport- | SRawStatement String- | SRestrictedImport RestrictedImport- | STopLevel TopLevel- | STypeclassDefinition TypeclassDefinition- | STypeclassInstance TypeclassInstance- | STypeSignature TypeSignature- | STypeSynonym TypeSynonym- | SUnrestrictedImport Identifier- deriving (Eq, Show)+data Statement ann+ = STopLevel (TopLevel ann)+ | SDataDeclaration (DataDeclaration ann)+ | SFunctionDefinition (FunctionDefinition ann)+ | SMacroDefinition (MacroDefinition ann)+ | SMacroImport (MacroImport ann)+ | SModuleDeclaration ann Identifier+ | SNewtypeDeclaration (NewtypeDeclaration ann)+ | SPragma (Pragma ann)+ | SQualifiedImport (QualifiedImport ann)+ | SRawStatement ann Text+ | SRestrictedImport (RestrictedImport ann)+ | STypeclassDefinition (TypeclassDefinition ann)+ | STypeclassInstance (TypeclassInstance ann)+ | STypeSignature (TypeSignature ann)+ | STypeSynonym (TypeSynonym ann)+ deriving (Data, Eq, Functor, Show) -instance ToHaskell Statement where- toHaskell :: Statement -> String- toHaskell (SDataDeclaration x) = toHaskell x- toHaskell (SFunctionDefinition x) = toHaskell x- toHaskell (SPragma x) = toHaskell x- toHaskell (SMacroDefinition x) = toHaskell x- toHaskell (SMacroImport x) = toHaskell x- toHaskell (SModuleDeclaration x) = "module " <> x <> " where"- toHaskell (SNewtypeDeclaration x) = toHaskell x- toHaskell (SQualifiedImport x) = toHaskell x- toHaskell (SRawStatement x) = x- toHaskell (SRestrictedImport x) = toHaskell x- toHaskell (STopLevel xs) = toHaskell xs- toHaskell (STypeclassDefinition x) = toHaskell x- toHaskell (STypeclassInstance x) = toHaskell x- toHaskell (STypeSignature x) = toHaskell x- toHaskell (STypeSynonym x) = toHaskell x- toHaskell (SUnrestrictedImport x) = "import " <> x+type Program ann = [Statement ann] makePrisms ''Statement -type Program = [Statement]- makeFieldsNoPrefix ''CaseBlock +makeFieldsNoPrefix ''TopLevel+ makeFieldsNoPrefix ''DataDeclaration makeFieldsNoPrefix ''FunctionApplication@@ -285,8 +294,6 @@ makeFieldsNoPrefix ''RestrictedImport -makeFieldsNoPrefix ''TopLevel- makeFieldsNoPrefix ''TypeclassDefinition makeFieldsNoPrefix ''TypeclassInstance@@ -295,238 +302,341 @@ makeFieldsNoPrefix ''TypeSynonym -instance ToHaskell CaseBlock where- toHaskell :: CaseBlock -> String+type SMExpression = Expression (Maybe SM.Expression)++type SMStatement = Statement (Maybe SM.Expression)++-- TODO Instead of using `HasAnnotation`, manually implement `HasAnn`+-- for everything instead.+class HasAnnotation a ann | a -> ann where+ getAnn :: a -> ann++-- TODO Figure out another way to do this,+-- since the current implementation needs overlapping instances.+instance {-# OVERLAPPABLE #-} (HasAnn a ann) => HasAnnotation a ann where+ getAnn :: a -> ann+ getAnn = (^. ann)++instance {-# OVERLAPPING #-} HasAnnotation (Expression ann) ann where+ getAnn :: Expression ann -> ann+ getAnn (ECaseBlock caseBlock) = caseBlock ^. ann+ getAnn (EEmptySExpression ann') = ann'+ getAnn (EFunctionApplication fnApp) = fnApp ^. ann+ getAnn (EIdentifier ann' _) = ann'+ getAnn (EIfBlock ifBlock) = ifBlock ^. ann+ getAnn (ELambda lambda) = lambda ^. ann+ getAnn (ELetBlock letBlock) = letBlock ^. ann+ getAnn (ELiteral literal) = getAnn literal+ getAnn (ERawExpression ann' _) = ann'+ getAnn (ERecordDefinition recordDefinition) = recordDefinition ^. ann+ getAnn (ERecordType recordType) = recordType ^. ann++instance {-# OVERLAPPING #-} HasAnnotation (Statement ann) ann where+ getAnn :: Statement ann -> ann+ getAnn (STopLevel topLevel) = getAnn topLevel+ getAnn (SDataDeclaration dataDeclaration) = getAnn dataDeclaration+ getAnn (SFunctionDefinition fnDef) = getAnn fnDef+ getAnn (SMacroDefinition macroDef) = getAnn macroDef+ getAnn (SMacroImport macroImport) = getAnn macroImport+ getAnn (SModuleDeclaration ann' _) = ann'+ getAnn (SNewtypeDeclaration newtypeDeclaration) = getAnn newtypeDeclaration+ getAnn (SPragma pragma) = getAnn pragma+ getAnn (SQualifiedImport qualifiedImport) = getAnn qualifiedImport+ getAnn (SRawStatement ann' _) = ann'+ getAnn (SRestrictedImport restrictedImport) = getAnn restrictedImport+ getAnn (STypeclassDefinition typeclassDefinition) = getAnn typeclassDefinition+ getAnn (STypeclassInstance typeclassInstance) = getAnn typeclassInstance+ getAnn (STypeSignature typeSig) = getAnn typeSig+ getAnn (STypeSynonym typeSynonym) = getAnn typeSynonym++instance {-# OVERLAPPING #-} HasAnnotation (Parse.Expression ann) ann where+ getAnn :: Parse.Expression ann -> ann+ getAnn (Parse.LiteralChar ann' _) = ann'+ getAnn (Parse.LiteralInt ann' _) = ann'+ getAnn (Parse.LiteralString ann' _) = ann'+ getAnn (Parse.SExpression ann' _) = ann'+ getAnn (Parse.Symbol ann' _) = ann'++instance {-# OVERLAPPING #-} HasAnnotation (Literal ann) ann where+ getAnn :: Literal ann -> ann+ getAnn (LChar ann' _) = ann'+ getAnn (LInt ann' _) = ann'+ getAnn (LString ann' _) = ann'++instance {-# OVERLAPPING #-} HasAnnotation (TypeDefinition ann) ann where+ getAnn :: TypeDefinition ann -> ann+ getAnn (ProperType ann' _) = ann'+ getAnn (TypeConstructor ann' _) = ann'++instance {-# OVERLAPPING #-} HasAnnotation (ImportSpecification ann) ann where+ getAnn :: ImportSpecification ann -> ann+ getAnn (ImportAll ann') = ann'+ getAnn (ImportOnly ann' _) = ann'++instance {-# OVERLAPPING #-} HasAnnotation (Import ann) ann where+ getAnn :: Import ann -> ann+ getAnn (ImportItem ann' _) = ann'+ getAnn (ImportType ann' _ _) = ann'++-- | Get a nested annotation, where the higher-level annotation is behind a `Maybe`.+getAnn' :: (HasAnnotation a (Maybe SM.Expression)) => a -> SM.SourceMetadata+getAnn' = getAnn >=> getAnn++mkHaskell :: (HasAnnotation a (Maybe SM.Expression)) => a -> Text -> SM.Output+mkHaskell x haskellRendering = SM.Output [annotate (getAnn' x) haskellRendering]++instance ToHaskell SMStatement where+ toHaskell :: SMStatement -> SM.Output+ toHaskell (STopLevel xs) = toHaskell xs+ toHaskell (SDataDeclaration x) = toHaskell x+ toHaskell (SFunctionDefinition x) = toHaskell x+ toHaskell (SPragma x) = toHaskell x+ toHaskell (SMacroDefinition x) = toHaskell x+ toHaskell (SMacroImport x) = toHaskell x+ toHaskell stmt@(SModuleDeclaration _ x) =+ mkHaskell stmt $ "module " <> x <> " where"+ toHaskell (SNewtypeDeclaration x) = toHaskell x+ toHaskell (SQualifiedImport x) = toHaskell x+ toHaskell stmt@(SRawStatement _ x) = mkHaskell stmt x+ toHaskell (SRestrictedImport x) = toHaskell x+ toHaskell (STypeclassDefinition x) = toHaskell x+ toHaskell (STypeclassInstance x) = toHaskell x+ toHaskell (STypeSignature x) = toHaskell x+ toHaskell (STypeSynonym x) = toHaskell x++instance ToHaskell (TypeDefinition (Maybe SM.Expression)) where+ toHaskell :: TypeDefinition (Maybe SM.Expression) -> SM.Output+ toHaskell (TypeConstructor _ x) = toHaskell x+ toHaskell stmt@(ProperType _ x) = mkHaskell stmt x++instance ToHaskell (CaseBlock (Maybe SM.Expression)) where+ toHaskell :: CaseBlock (Maybe SM.Expression) -> SM.Output toHaskell caseBlock =- surround Parentheses $- "case " <> toHaskell (caseBlock ^. expr) <> " of " <>- renderBlock (map matchToHaskell (caseBlock ^. matches))+ SM.surround Parentheses $ mkHaskell caseBlock "case " <>+ toHaskell (caseBlock ^. expr) <>+ mkHaskell caseBlock " of " <>+ SM.renderBlock (map matchToHaskell (caseBlock ^. matches)) where- matchToHaskell (pat, result) = toHaskell pat <> " -> " <> toHaskell result+ matchToHaskell (pat, result) =+ toHaskell pat <> mkHaskell caseBlock " -> " <> toHaskell result -instance ToHaskell FunctionApplication where- toHaskell :: FunctionApplication -> String+instance ToHaskell (FunctionApplication (Maybe SM.Expression)) where+ toHaskell :: FunctionApplication (Maybe SM.Expression) -> SM.Output toHaskell functionApplication = case functionApplication ^. function of- EIdentifier "list" ->- surround SquareBrackets $- delimit Commas (map toHaskell $ functionApplication ^. arguments)+ EIdentifier _ "list" ->+ SM.surround SquareBrackets $+ SM.delimit Commas (map toHaskell $ functionApplication ^. arguments) _ ->- surround Parentheses $- toHaskell (functionApplication ^. function) <> " " <>- delimit Spaces (map toHaskell $ functionApplication ^. arguments)+ SM.surround Parentheses $ toHaskell (functionApplication ^. function) <>+ mkHaskell functionApplication " " <>+ SM.delimit Spaces (map toHaskell $ functionApplication ^. arguments) -instance ToHaskell TypeSignature where- toHaskell :: TypeSignature -> String+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@(LInt _ x) = mkHaskell literal $ showText x+ toHaskell literal@(LString _ x) =+ mkHaskell literal $ Display.surround DoubleQuotes (handleCharEscapes x)++instance ToHaskell (TypeSignature (Maybe SM.Expression)) where+ toHaskell :: TypeSignature (Maybe SM.Expression) -> SM.Output toHaskell typeSignature =- toHaskell (EIdentifier (typeSignature ^. name)) <> " :: " <>+ toHaskell (EIdentifier (typeSignature ^. ann) (typeSignature ^. name)) <>+ mkHaskell typeSignature " :: " <> toHaskell (typeSignature ^. typeDefinition) -instance ToHaskell FunctionDefinition where- toHaskell :: FunctionDefinition -> String+instance ToHaskell (FunctionDefinition (Maybe SM.Expression)) where+ toHaskell :: FunctionDefinition (Maybe SM.Expression) -> SM.Output toHaskell fnDef =- toHaskell (EIdentifier (fnDef ^. name)) <> " " <>- delimit Spaces (map toHaskell (fnDef ^. arguments)) <>- " = " <>+ toHaskell (EIdentifier (fnDef ^. ann) (fnDef ^. name)) <>+ mkHaskell fnDef " " <>+ SM.delimit Spaces (map toHaskell (fnDef ^. arguments)) <>+ mkHaskell fnDef " = " <> toHaskell (fnDef ^. body) <>- " where " <>- renderBlock (map toHaskell (fnDef ^. whereBindings))+ auxBindings+ where+ auxBindings =+ if null (fnDef ^. whereBindings)+ then mempty+ else mkHaskell fnDef " where " <>+ SM.renderBlock (map toHaskell (fnDef ^. whereBindings)) -instance ToHaskell DataDeclaration where- toHaskell :: DataDeclaration -> String+instance ToHaskell (DataDeclaration (Maybe SM.Expression)) where+ toHaskell :: DataDeclaration (Maybe SM.Expression) -> SM.Output toHaskell dataDeclaration =- "data " <> toHaskell (dataDeclaration ^. typeDefinition) <> " = " <>- delimit+ mkHaskell dataDeclaration "data " <>+ toHaskell (dataDeclaration ^. typeDefinition) <>+ mkHaskell dataDeclaration " = " <>+ SM.delimit Pipes- (map (removeSurroundingParentheses . toHaskell) $- dataDeclaration ^. constructors)- where- removeSurroundingParentheses = tail . init+ (map (removeSurroundingParentheses . toHaskell) $ dataDeclaration ^.+ constructors) -instance ToHaskell IfBlock where- toHaskell :: IfBlock -> String+removeSurroundingParentheses :: SM.Output -> SM.Output+removeSurroundingParentheses = removeOpen . removeClosed+ where+ removeOpen = _Wrapped . _head . unannotated %~ T.tail+ removeClosed = _Wrapped . _last . unannotated %~ T.init++instance ToHaskell (IfBlock (Maybe SM.Expression)) where+ toHaskell :: IfBlock (Maybe SM.Expression) -> SM.Output toHaskell ifBlock =- "if " <> toHaskell (ifBlock ^. cond) <> " then " <>+ mkHaskell ifBlock "if " <> toHaskell (ifBlock ^. cond) <>+ mkHaskell ifBlock " then " <> toHaskell (ifBlock ^. ifTrue) <>- " else " <>+ mkHaskell ifBlock " else " <> toHaskell (ifBlock ^. ifFalse) -instance ToHaskell NewtypeDeclaration where- toHaskell :: NewtypeDeclaration -> String+instance ToHaskell (NewtypeDeclaration (Maybe SM.Expression)) where+ toHaskell :: NewtypeDeclaration (Maybe SM.Expression) -> SM.Output toHaskell newtypeDeclaration =- "newtype " <> toHaskell (newtypeDeclaration ^. typeDefinition) <> " = " <>+ mkHaskell newtypeDeclaration "newtype " <>+ toHaskell (newtypeDeclaration ^. typeDefinition) <>+ mkHaskell newtypeDeclaration " = " <> removeSurroundingParentheses (toHaskell (newtypeDeclaration ^. constructor))- where- removeSurroundingParentheses = tail . init -instance ToHaskell Lambda where- toHaskell :: Lambda -> String+instance ToHaskell (Lambda (Maybe SM.Expression)) where+ toHaskell :: Lambda (Maybe SM.Expression) -> SM.Output toHaskell lambda =- surround Parentheses $- "\\" <> delimit Spaces (map toHaskell (lambda ^. arguments)) <> " -> " <>+ SM.surround Parentheses $ mkHaskell lambda "\\" <>+ SM.delimit Spaces (map toHaskell (lambda ^. arguments)) <>+ mkHaskell lambda " -> " <> toHaskell (lambda ^. body) -instance ToHaskell Pragma where- toHaskell :: Pragma -> String- toHaskell pragma = renderPragma (pragma ^. pragmaSpecification)+instance ToHaskell (Pragma (Maybe SM.Expression)) where+ toHaskell :: Pragma (Maybe SM.Expression) -> SM.Output+ toHaskell pragma =+ mkHaskell pragma $ Display.renderPragma (pragma ^. pragmaSpecification) -instance ToHaskell LetBlock where- toHaskell :: LetBlock -> String+instance ToHaskell (LetBlock (Maybe SM.Expression)) where+ toHaskell :: LetBlock (Maybe SM.Expression) -> SM.Output toHaskell letBlock =- surround Parentheses $- "let " <> renderBlock (map bindingToHaskell (letBlock ^. bindings)) <>- " in " <>+ SM.surround Parentheses $ mkHaskell letBlock "let " <>+ SM.renderBlock (map bindingToHaskell (letBlock ^. bindings)) <>+ mkHaskell letBlock " in " <> toHaskell (letBlock ^. body) where bindingToHaskell (pattern', value) =- toHaskell pattern' <> " = " <> toHaskell value+ toHaskell pattern' <> mkHaskell letBlock " = " <> toHaskell value -instance ToHaskell MacroDefinition where- toHaskell :: MacroDefinition -> String+instance ToHaskell (MacroDefinition (Maybe SM.Expression)) where+ toHaskell :: MacroDefinition (Maybe SM.Expression) -> SM.Output toHaskell macroDefinition = toHaskell (macroDefinition ^. functionDefinition) -instance ToHaskell MacroImport where- toHaskell :: MacroImport -> String+instance ToHaskell (MacroImport (Maybe SM.Expression)) where+ toHaskell :: MacroImport (Maybe SM.Expression) -> SM.Output toHaskell macroImport = toHaskell $ RestrictedImport+ (macroImport ^. ann) (macroImport ^. moduleName)- (ImportOnly $- map (ImportItem . hygenisizeMacroName) $ macroImport ^. imports)+ (ImportOnly (macroImport ^. ann) $+ map (ImportItem (macroImport ^. ann) . hygenisizeMacroName) $+ macroImport ^.+ imports) -instance ToHaskell QualifiedImport where- toHaskell :: QualifiedImport -> String+instance ToHaskell (ImportSpecification (Maybe SM.Expression)) where+ toHaskell :: ImportSpecification (Maybe SM.Expression) -> SM.Output+ toHaskell importSpec@(ImportAll _) = mkHaskell importSpec ""+ toHaskell (ImportOnly _ importList) =+ SM.surround Parentheses $ SM.delimit Commas $ map toHaskell importList++instance ToHaskell (QualifiedImport (Maybe SM.Expression)) where+ toHaskell :: QualifiedImport (Maybe SM.Expression) -> SM.Output toHaskell qualifiedImport =- "import qualified " <> qualifiedImport ^. moduleName <> " as " <>- qualifiedImport ^.- alias <>+ mkHaskell+ qualifiedImport+ ("import qualified " <> qualifiedImport ^. moduleName <> " as " <>+ qualifiedImport ^.+ alias) <> toHaskell (qualifiedImport ^. imports) -instance ToHaskell RecordDefinition where- toHaskell :: RecordDefinition -> String+instance ToHaskell (Expression (Maybe SM.Expression)) where+ toHaskell :: Expression (Maybe SM.Expression) -> SM.Output+ toHaskell (ECaseBlock x) = toHaskell x+ toHaskell expr'@(EEmptySExpression _) = mkHaskell expr' "()"+ toHaskell (EFunctionApplication x) = toHaskell x+ toHaskell expr'@(EIdentifier _ x) =+ mkHaskell expr' $+ if isOperator x+ then Display.surround Parentheses x+ else x+ toHaskell (EIfBlock x) = toHaskell x+ toHaskell (ELambda x) = toHaskell x+ toHaskell (ELetBlock x) = toHaskell x+ toHaskell (ELiteral x) = toHaskell x+ toHaskell expr'@(ERawExpression _ x) = mkHaskell expr' x+ toHaskell (ERecordDefinition x) = toHaskell x+ toHaskell (ERecordType x) = toHaskell x++instance ToHaskell (RecordDefinition (Maybe SM.Expression)) where+ toHaskell :: RecordDefinition (Maybe SM.Expression) -> SM.Output toHaskell recordDefinition =- surround CurlyBraces $- delimit Commas $+ SM.surround CurlyBraces $ SM.delimit Commas $ map- (\(var, val) -> var <> " = " <> toHaskell val)+ (\(var, val) -> mkHaskell recordDefinition (var <> " = ") <> toHaskell val) (recordDefinition ^. bindings) -instance ToHaskell RecordType where- toHaskell :: RecordType -> String+instance ToHaskell (RecordType (Maybe SM.Expression)) where+ toHaskell :: RecordType (Maybe SM.Expression) -> SM.Output toHaskell recordDefinition =- surround CurlyBraces $- delimit Commas $+ SM.surround CurlyBraces $ SM.delimit Commas $ map- (\(field, ty) -> field <> " :: " <> toHaskell ty)+ (\(field, ty) ->+ mkHaskell recordDefinition (field <> " :: ") <> toHaskell ty) (recordDefinition ^. fields) -instance ToHaskell RestrictedImport where- toHaskell :: RestrictedImport -> String+instance ToHaskell (Import (Maybe SM.Expression)) where+ toHaskell :: Import (Maybe SM.Expression) -> SM.Output+ toHaskell import'@(ImportItem _ x) =+ mkHaskell import' $+ if isOperator x+ then Display.surround Parentheses x+ else x+ toHaskell import'@(ImportType _ typeName imports') =+ mkHaskell import' $ typeName <>+ Display.surround Parentheses (Display.delimit Commas imports')++instance ToHaskell (RestrictedImport (Maybe SM.Expression)) where+ toHaskell :: RestrictedImport (Maybe SM.Expression) -> SM.Output toHaskell restrictedImport =- "import " <> restrictedImport ^. moduleName <>+ mkHaskell restrictedImport ("import " <> restrictedImport ^. moduleName) <> toHaskell (restrictedImport ^. imports) -instance ToHaskell TopLevel where- toHaskell :: TopLevel -> String- toHaskell topLevel = delimit Newlines $ map toHaskell (topLevel ^. statements)+instance ToHaskell (TopLevel (Maybe SM.Expression)) where+ toHaskell :: TopLevel (Maybe SM.Expression) -> SM.Output+ toHaskell topLevel =+ SM.delimit Newlines $ map toHaskell (topLevel ^. statements) -instance ToHaskell TypeclassDefinition where- toHaskell :: TypeclassDefinition -> String+instance ToHaskell (TypeclassDefinition (Maybe SM.Expression)) where+ toHaskell :: TypeclassDefinition (Maybe SM.Expression) -> SM.Output toHaskell typeclassDefinition =- "class " <>- surround+ mkHaskell typeclassDefinition "class " <>+ SM.surround Parentheses- (delimit Commas (map toHaskell (typeclassDefinition ^. constraints))) <>- " => " <>+ (SM.delimit Commas (map toHaskell (typeclassDefinition ^. constraints))) <>+ mkHaskell typeclassDefinition " => " <> toHaskell (typeclassDefinition ^. name) <>- " where " <>- renderBlock (map toHaskell $ typeclassDefinition ^. signatures)+ mkHaskell typeclassDefinition " where " <>+ SM.renderBlock (map toHaskell $ typeclassDefinition ^. signatures) -instance ToHaskell TypeclassInstance where- toHaskell :: TypeclassInstance -> String+instance ToHaskell (TypeclassInstance (Maybe SM.Expression)) where+ toHaskell :: TypeclassInstance (Maybe SM.Expression) -> SM.Output toHaskell typeclassInstance =- "instance " <> toHaskell (typeclassInstance ^. instanceName) <> " where " <>- renderBlock (map toHaskell $ typeclassInstance ^. definitions)+ mkHaskell typeclassInstance "instance " <>+ toHaskell (typeclassInstance ^. instanceName) <>+ mkHaskell typeclassInstance " where " <>+ SM.renderBlock (map toHaskell $ typeclassInstance ^. definitions) -instance ToHaskell TypeSynonym where- toHaskell :: TypeSynonym -> String+instance ToHaskell (TypeSynonym (Maybe SM.Expression)) where+ toHaskell :: TypeSynonym (Maybe SM.Expression) -> SM.Output toHaskell typeSynonym =- "type " <> toHaskell (typeSynonym ^. alias) <> " = " <>+ mkHaskell typeSynonym "type " <> toHaskell (typeSynonym ^. alias) <>+ mkHaskell typeSynonym " = " <> toHaskell (typeSynonym ^. definition) -instance Recursive Expression where- bottomUpFmap :: (Expression -> Expression) -> Expression -> Expression- bottomUpFmap f x =- f $- case x of- ECaseBlock caseBlock ->- ECaseBlock $- caseBlock & expr %~ bottomUpFmap f &- matches %~ map (bottomUpFmap f *** bottomUpFmap f)- EEmptySExpression -> x- EFunctionApplication functionApplication ->- EFunctionApplication $- functionApplication & function %~ bottomUpFmap f &- arguments %~ map (bottomUpFmap f)- EIdentifier _ -> x- EIfBlock ifBlock ->- EIfBlock $- ifBlock & cond %~ bottomUpFmap f & ifTrue %~ bottomUpFmap f &- ifFalse %~ bottomUpFmap f- ELambda lambda ->- ELambda $- lambda & arguments %~ map (bottomUpFmap f) & body %~ bottomUpFmap f- ELetBlock letBlock ->- ELetBlock $- letBlock & bindings %~ map (bottomUpFmap f *** bottomUpFmap f) &- body %~ bottomUpFmap f- ELiteral literal ->- case literal of- LChar _ -> x- LInt _ -> x- LString _ -> x- ERawExpression _ -> x- ERecordDefinition _ -> x- ERecordType _ -> x- bottomUpTraverse ::- (Monad m) => (Expression -> m Expression) -> Expression -> m Expression- bottomUpTraverse f x =- f =<<- case x of- ECaseBlock caseBlock ->- ECaseBlock <$>- (CaseBlock <$> bottomUpTraverse f (caseBlock ^. expr) <*>- traverse- (\(a, b) -> (,) <$> bottomUpTraverse f a <*> bottomUpTraverse f b)- (caseBlock ^. matches))- EEmptySExpression -> pure x- EFunctionApplication functionApplication ->- EFunctionApplication <$>- (FunctionApplication <$>- bottomUpTraverse f (functionApplication ^. function) <*>- traverse (bottomUpTraverse f) (functionApplication ^. arguments))- EIdentifier _ -> pure x- EIfBlock ifBlock ->- EIfBlock <$>- (IfBlock <$> bottomUpTraverse f (ifBlock ^. cond) <*>- bottomUpTraverse f (ifBlock ^. ifTrue) <*>- bottomUpTraverse f (ifBlock ^. ifFalse))- ELambda lambda ->- ELambda <$>- (Lambda <$> traverse (bottomUpTraverse f) (lambda ^. arguments) <*>- bottomUpTraverse f (lambda ^. body))- ELetBlock letBlock ->- ELetBlock <$>- (LetBlock <$>- traverse- (\(a, b) -> (a, ) <$> bottomUpTraverse f b)- (letBlock ^. bindings) <*>- bottomUpTraverse f (letBlock ^. body))- ELiteral literal ->- case literal of- LChar _ -> pure x- LInt _ -> pure x- LString _ -> pure x- ERawExpression _ -> pure x- ERecordDefinition _ -> pure x- ERecordType _ -> pure x+statementsToProgram :: [SMStatement] -> SMStatement+statementsToProgram = STopLevel . TopLevel Nothing
src/Axel/Denormalize.hs view
@@ -1,5 +1,7 @@ module Axel.Denormalize where +import Axel.Prelude+ import Axel.AST ( Expression(ECaseBlock, EEmptySExpression, EFunctionApplication, EIdentifier, EIfBlock, ELambda, ELetBlock, ELiteral,@@ -7,11 +9,13 @@ , Import(ImportItem, ImportType) , ImportSpecification(ImportAll, ImportOnly) , Literal(LChar, LInt, LString)+ , SMExpression+ , SMStatement , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition, SMacroImport, SModuleDeclaration, SNewtypeDeclaration, SPragma, SQualifiedImport, SRawStatement, SRestrictedImport, STopLevel, STypeSignature, STypeSynonym, STypeclassDefinition,- STypeclassInstance, SUnrestrictedImport)+ STypeclassInstance) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor) , alias@@ -28,6 +32,7 @@ , fields , function , functionDefinition+ , getAnn' , ifFalse , ifTrue , imports@@ -40,182 +45,258 @@ , typeDefinition , whereBindings )-import qualified Axel.Parse as Parse+import qualified Axel.Parse.AST as Parse ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression, Symbol) )+import qualified Axel.Sourcemap as SM (Expression) import Control.Lens.Operators ((^.)) -denormalizeExpression :: Expression -> Parse.Expression+import qualified Data.Text as T++-- | Metadata is only approximately restored. Thus, `normalizeExpression` and+-- | `denormalizeExpression` are only inverses if metadata information is+-- | ignored, although they should be pretty close either way.+denormalizeExpression :: SMExpression -> SM.Expression denormalizeExpression (ECaseBlock caseBlock) =- let denormalizedCases =+ let ann' = getAnn' caseBlock+ denormalizedCases = map (\(pat, res) -> Parse.SExpression+ ann' [denormalizeExpression pat, denormalizeExpression res]) (caseBlock ^. matches)- in Parse.SExpression $ Parse.Symbol "case" :+ in Parse.SExpression ann' $ Parse.Symbol ann' "case" : denormalizeExpression (caseBlock ^. expr) : denormalizedCases-denormalizeExpression EEmptySExpression = Parse.SExpression []+denormalizeExpression expr'@(EEmptySExpression _) =+ Parse.SExpression (getAnn' expr') [] denormalizeExpression (EFunctionApplication functionApplication) =- Parse.SExpression $ denormalizeExpression (functionApplication ^. function) :+ Parse.SExpression (getAnn' functionApplication) $+ denormalizeExpression (functionApplication ^. function) : map denormalizeExpression (functionApplication ^. arguments)-denormalizeExpression (EIdentifier x) = Parse.Symbol x+denormalizeExpression expr'@(EIdentifier _ x) =+ Parse.Symbol (getAnn' expr') (T.unpack x) denormalizeExpression (EIfBlock ifBlock) =- Parse.SExpression- [ Parse.Symbol "if"- , denormalizeExpression (ifBlock ^. cond)- , denormalizeExpression (ifBlock ^. ifTrue)- , denormalizeExpression (ifBlock ^. ifFalse)- ]+ let ann' = getAnn' ifBlock+ in Parse.SExpression+ ann'+ [ Parse.Symbol ann' "if"+ , denormalizeExpression (ifBlock ^. cond)+ , denormalizeExpression (ifBlock ^. ifTrue)+ , denormalizeExpression (ifBlock ^. ifFalse)+ ] denormalizeExpression (ELambda lambda) =- let denormalizedArguments =- Parse.SExpression $ map denormalizeExpression (lambda ^. arguments)+ let ann' = getAnn' lambda+ denormalizedArguments =+ Parse.SExpression ann' $ map denormalizeExpression (lambda ^. arguments) in Parse.SExpression- [ Parse.Symbol "\\"+ ann'+ [ Parse.Symbol ann' "\\" , denormalizedArguments , denormalizeExpression (lambda ^. body) ] denormalizeExpression (ELetBlock letBlock) =- let denormalizedBindings =- Parse.SExpression $+ let ann' = getAnn' letBlock+ denormalizedBindings =+ Parse.SExpression ann' $ map (\(var, val) -> Parse.SExpression+ ann' [denormalizeExpression var, denormalizeExpression val]) (letBlock ^. bindings) in Parse.SExpression- [ Parse.Symbol "let"+ ann'+ [ Parse.Symbol ann' "let" , denormalizedBindings , denormalizeExpression (letBlock ^. body) ] denormalizeExpression (ELiteral x) = case x of- LChar char -> Parse.LiteralChar char- LInt int -> Parse.LiteralInt int- LString string -> Parse.LiteralString string-denormalizeExpression (ERawExpression rawSource) =- Parse.SExpression [Parse.Symbol "raw", Parse.LiteralString rawSource]+ LChar _ char -> Parse.LiteralChar (getAnn' x) char+ LInt _ int -> Parse.LiteralInt (getAnn' x) int+ LString _ string -> Parse.LiteralString (getAnn' x) (T.unpack string)+denormalizeExpression expr'@(ERawExpression _ rawSource) =+ let ann' = getAnn' expr'+ in Parse.SExpression+ ann'+ [Parse.Symbol ann' "raw", Parse.LiteralString ann' (T.unpack rawSource)] denormalizeExpression (ERecordDefinition recordDefinition) =- let denormalizedBindings =+ let ann' = getAnn' recordDefinition+ denormalizedBindings = map (\(var, val) ->- Parse.SExpression [Parse.Symbol var, denormalizeExpression val])+ Parse.SExpression+ ann'+ [Parse.Symbol ann' (T.unpack var), denormalizeExpression val]) (recordDefinition ^. bindings)- in Parse.SExpression (Parse.Symbol "record" : denormalizedBindings)+ in Parse.SExpression ann' (Parse.Symbol ann' "record" : denormalizedBindings) denormalizeExpression (ERecordType recordType) =- let denormalizedFields =+ let ann' = getAnn' recordType+ denormalizedFields = map (\(field, ty) ->- Parse.SExpression [Parse.Symbol field, denormalizeExpression ty])+ Parse.SExpression+ ann'+ [Parse.Symbol ann' (T.unpack field), denormalizeExpression ty]) (recordType ^. fields)- in Parse.SExpression (Parse.Symbol "recordType" : denormalizedFields)+ in Parse.SExpression+ ann'+ (Parse.Symbol ann' "recordType" : denormalizedFields) -denormalizeImportSpecification :: ImportSpecification -> Parse.Expression-denormalizeImportSpecification ImportAll = Parse.Symbol "all"-denormalizeImportSpecification (ImportOnly importList) =- Parse.SExpression $ map denormalizeImport importList+denormalizeImportSpecification ::+ ImportSpecification (Maybe SM.Expression) -> SM.Expression+denormalizeImportSpecification importSpec@(ImportAll _) =+ Parse.Symbol (getAnn' importSpec) "all"+denormalizeImportSpecification importSpec@(ImportOnly _ importList) =+ Parse.SExpression (getAnn' importSpec) $ map denormalizeImport importList where- denormalizeImport (ImportItem item) = Parse.Symbol item- denormalizeImport (ImportType type' items) =- Parse.SExpression (Parse.Symbol type' : map Parse.Symbol items)+ denormalizeImport importList'@(ImportItem _ item) =+ Parse.Symbol (getAnn' importList') (T.unpack item)+ denormalizeImport importList'@(ImportType _ type' items) =+ let ann' = getAnn' importList'+ in Parse.SExpression+ ann'+ (Parse.Symbol ann' (T.unpack type') :+ map (Parse.Symbol ann' . T.unpack) items) -denormalizeStatement :: Statement -> Parse.Expression+denormalizeStatement :: SMStatement -> SM.Expression denormalizeStatement (SDataDeclaration dataDeclaration) =- let denormalizedTypeDefinition =+ let ann' = getAnn' dataDeclaration+ denormalizedTypeDefinition = case dataDeclaration ^. typeDefinition of- TypeConstructor typeConstructor ->+ TypeConstructor _ typeConstructor -> denormalizeExpression $ EFunctionApplication typeConstructor- ProperType properType -> Parse.Symbol properType+ ProperType _ properType ->+ Parse.Symbol+ (getAnn' $ dataDeclaration ^. typeDefinition)+ (T.unpack properType) in Parse.SExpression- (Parse.Symbol "data" : denormalizedTypeDefinition :+ ann'+ (Parse.Symbol ann' "data" : denormalizedTypeDefinition : map (denormalizeExpression . EFunctionApplication) (dataDeclaration ^. constructors)) denormalizeStatement (SFunctionDefinition fnDef) =- Parse.SExpression $ Parse.Symbol "=" : Parse.Symbol (fnDef ^. name) :- Parse.SExpression (map denormalizeExpression (fnDef ^. arguments)) :- denormalizeExpression (fnDef ^. body) :- map (denormalizeStatement . SFunctionDefinition) (fnDef ^. whereBindings)+ let ann' = getAnn' fnDef+ in Parse.SExpression ann' $ Parse.Symbol ann' "=" :+ Parse.Symbol ann' (T.unpack $ fnDef ^. name) :+ Parse.SExpression ann' (map denormalizeExpression (fnDef ^. arguments)) :+ denormalizeExpression (fnDef ^. body) :+ map (denormalizeStatement . SFunctionDefinition) (fnDef ^. whereBindings) denormalizeStatement (SMacroDefinition macroDef) =- Parse.SExpression $ Parse.Symbol "=macro" :- Parse.Symbol (macroDef ^. functionDefinition . name) :- Parse.SExpression- (map denormalizeExpression (macroDef ^. functionDefinition . arguments)) :- denormalizeExpression (macroDef ^. functionDefinition . body) :- map- (denormalizeStatement . SFunctionDefinition)- (macroDef ^. functionDefinition . whereBindings)+ 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 (macroDef ^. functionDefinition . body) :+ map+ (denormalizeStatement . SFunctionDefinition)+ (macroDef ^. functionDefinition . whereBindings) denormalizeStatement (SMacroImport macroImport) =- Parse.SExpression- [ Parse.Symbol "importm"- , Parse.Symbol $ macroImport ^. moduleName- , Parse.SExpression $ map Parse.Symbol (macroImport ^. imports)- ]-denormalizeStatement (SModuleDeclaration identifier) =- Parse.SExpression [Parse.Symbol "module", Parse.Symbol identifier]+ let ann' = getAnn' macroImport+ in Parse.SExpression+ ann'+ [ Parse.Symbol ann' "importm"+ , Parse.Symbol ann' (T.unpack $ macroImport ^. moduleName)+ , Parse.SExpression ann' $+ map (Parse.Symbol ann' . T.unpack) (macroImport ^. imports)+ ]+denormalizeStatement stmt@(SModuleDeclaration _ identifier) =+ let ann' = getAnn' stmt+ in Parse.SExpression+ ann'+ [Parse.Symbol ann' "module", Parse.Symbol ann' (T.unpack identifier)] denormalizeStatement (SNewtypeDeclaration newtypeDeclaration) =- let denormalizedTypeDefinition =+ let ann' = getAnn' newtypeDeclaration+ denormalizedTypeDefinition = case newtypeDeclaration ^. typeDefinition of- TypeConstructor typeConstructor ->+ TypeConstructor _ typeConstructor -> denormalizeExpression $ EFunctionApplication typeConstructor- ProperType properType -> Parse.Symbol properType+ ProperType _ properType ->+ Parse.Symbol+ (getAnn' $ newtypeDeclaration ^. typeDefinition)+ (T.unpack properType) in Parse.SExpression- [ Parse.Symbol "newtype"+ ann'+ [ Parse.Symbol ann' "newtype" , denormalizedTypeDefinition , denormalizeExpression $ EFunctionApplication (newtypeDeclaration ^. constructor) ] denormalizeStatement (SPragma pragma) =- Parse.SExpression- [Parse.Symbol "pragma", Parse.LiteralString (pragma ^. pragmaSpecification)]+ let ann' = getAnn' pragma+ in Parse.SExpression+ ann'+ [ Parse.Symbol ann' "pragma"+ , Parse.LiteralString ann' (T.unpack $ pragma ^. pragmaSpecification)+ ] denormalizeStatement (SQualifiedImport qualifiedImport) =- Parse.SExpression- [ Parse.Symbol "importq"- , Parse.Symbol $ qualifiedImport ^. moduleName- , Parse.Symbol $ qualifiedImport ^. alias- , denormalizeImportSpecification (qualifiedImport ^. imports)- ]-denormalizeStatement (SRawStatement rawSource) =- Parse.SExpression [Parse.Symbol "raw", Parse.LiteralString rawSource]+ let ann' = getAnn' qualifiedImport+ in Parse.SExpression+ ann'+ [ Parse.Symbol ann' "importq"+ , Parse.Symbol ann' (T.unpack $ qualifiedImport ^. moduleName)+ , Parse.Symbol ann' (T.unpack $ qualifiedImport ^. alias)+ , denormalizeImportSpecification (qualifiedImport ^. imports)+ ]+denormalizeStatement expr'@(SRawStatement _ rawSource) =+ let ann' = getAnn' expr'+ in Parse.SExpression+ ann'+ [Parse.Symbol ann' "raw", Parse.LiteralString ann' (T.unpack rawSource)] denormalizeStatement (SRestrictedImport restrictedImport) =- Parse.SExpression- [ Parse.Symbol "import"- , Parse.Symbol $ restrictedImport ^. moduleName- , denormalizeImportSpecification (restrictedImport ^. imports)- ]-denormalizeStatement (STopLevel (TopLevel statements)) =- Parse.SExpression $ Parse.Symbol "begin" : map denormalizeStatement statements+ let ann' = getAnn' restrictedImport+ in Parse.SExpression+ ann'+ [ Parse.Symbol ann' "import"+ , Parse.Symbol ann' (T.unpack $ restrictedImport ^. moduleName)+ , denormalizeImportSpecification (restrictedImport ^. imports)+ ]+denormalizeStatement stmt@(STopLevel (TopLevel _ statements)) =+ let ann' = getAnn' stmt+ in Parse.SExpression ann' $ Parse.Symbol ann' "begin" :+ map denormalizeStatement statements denormalizeStatement (STypeclassDefinition typeclassDefinition) =- Parse.SExpression- (Parse.Symbol "class" :- Parse.SExpression- (Parse.Symbol "list" :- map denormalizeExpression (typeclassDefinition ^. constraints)) :- denormalizeExpression (typeclassDefinition ^. name) :- map- (denormalizeStatement . STypeSignature)- (typeclassDefinition ^. signatures))+ let ann' = getAnn' typeclassDefinition+ in Parse.SExpression+ ann'+ (Parse.Symbol ann' "class" :+ Parse.SExpression+ ann'+ (Parse.Symbol ann' "list" :+ map denormalizeExpression (typeclassDefinition ^. constraints)) :+ denormalizeExpression (typeclassDefinition ^. name) :+ map+ (denormalizeStatement . STypeSignature)+ (typeclassDefinition ^. signatures)) denormalizeStatement (STypeclassInstance typeclassInstance) =- Parse.SExpression- (Parse.Symbol "instance" :- denormalizeExpression (typeclassInstance ^. instanceName) :- map- (denormalizeStatement . SFunctionDefinition)- (typeclassInstance ^. definitions))+ let ann' = getAnn' typeclassInstance+ in Parse.SExpression+ ann'+ (Parse.Symbol ann' "instance" :+ denormalizeExpression (typeclassInstance ^. instanceName) :+ map+ (denormalizeStatement . SFunctionDefinition)+ (typeclassInstance ^. definitions)) denormalizeStatement (STypeSignature typeSig) =- Parse.SExpression- [ Parse.Symbol "::"- , Parse.Symbol (typeSig ^. name)- , denormalizeExpression (typeSig ^. typeDefinition)- ]+ let ann' = getAnn' typeSig+ in Parse.SExpression+ ann'+ [ Parse.Symbol ann' "::"+ , Parse.Symbol ann' (T.unpack $ typeSig ^. name)+ , denormalizeExpression (typeSig ^. typeDefinition)+ ] denormalizeStatement (STypeSynonym typeSynonym) =- Parse.SExpression- [ Parse.Symbol "type"- , denormalizeExpression (typeSynonym ^. alias)- , denormalizeExpression (typeSynonym ^. definition)- ]-denormalizeStatement (SUnrestrictedImport identifier) =- Parse.SExpression [Parse.Symbol "importUnrestricted", Parse.Symbol identifier]+ let ann' = getAnn' typeSynonym+ in Parse.SExpression+ ann'+ [ Parse.Symbol ann' "type"+ , denormalizeExpression (typeSynonym ^. alias)+ , denormalizeExpression (typeSynonym ^. definition)+ ]
+ src/Axel/Eff.hs view
@@ -0,0 +1,7 @@+module Axel.Eff where++import qualified Polysemy as Sem++type Callback effs fn a+ = forall openEffs. (Sem.Members effs openEffs) =>+ fn (Sem.Sem openEffs a)
+ src/Axel/Eff/App.hs view
@@ -0,0 +1,31 @@+module Axel.Eff.App where++import Axel.Prelude++import Axel.Eff.Console (Console, runConsole)+import Axel.Eff.Error (Error, renderError, unsafeRunError)+import Axel.Eff.FileSystem (FileSystem, runFileSystem)+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++type AppEffs+ = '[ Log, Console, Sem.Error Error, FileSystem, Ghci, Process, Resource, Random, Time, Sem.Embed IO]++runApp :: Sem.Sem AppEffs a -> IO a+runApp =+ Sem.runM .+ runTime .+ runRandom .+ runResource .+ runProcess .+ runGhci .+ runFileSystem .+ unsafeRunError renderError .+ runConsole . runLogAsFileSystem (FilePath "axelCompilation.log")
src/Axel/Eff/Console.hs view
@@ -1,28 +1,39 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-} module Axel.Eff.Console where -import Prelude hiding (putStr)-import qualified Prelude+import Axel.Prelude -import Control.Monad.Freer (type (~>), Eff, LastMember, Member, interpretM)-import Control.Monad.Freer.TH (makeEffect)+import qualified Data.Text as T+import qualified Data.Text.IO as T -data Console r where- PutStr :: String -> Console ()+import qualified Polysemy as Sem -makeEffect ''Console+import qualified System.Console.ANSI as ANSI (getTerminalSize) -runEff :: (LastMember IO effs) => Eff (Console ': effs) ~> Eff effs-runEff =- interpretM $ \case- PutStr str -> Prelude.putStr str+data Console m a where+ GetTerminalSize :: Console m (Maybe (Int, Int))+ PutStr :: Text -> Console m () -putStrLn :: (Member Console effs) => String -> Eff effs ()-putStrLn str = putStr (str <> "\n")+Sem.makeSem ''Console++runConsole ::+ (Sem.Member (Sem.Embed IO) effs)+ => Sem.Sem (Console ': effs) a+ -> Sem.Sem effs a+runConsole =+ Sem.interpret $ \case+ GetTerminalSize -> Sem.embed ANSI.getTerminalSize+ PutStr str -> Sem.embed $ T.putStr str++putStrLn :: (Sem.Member Console effs) => Text -> Sem.Sem effs ()+putStrLn = putStr . (<> "\n")++putHorizontalLine :: (Sem.Member Console effs) => Sem.Sem effs ()+putHorizontalLine = do+ maybeTerminalSize <- getTerminalSize+ case maybeTerminalSize of+ Just (_, width) -> putStrLn $ T.replicate width "\x2500"+ Nothing -> pure ()
+ src/Axel/Eff/Error.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Axel.Eff.Error where++import Axel.Prelude++import Axel.Parse.AST (getAnn, toAxel)+import qualified Axel.Sourcemap as SM+import Axel.Utils.Text (Renderer)++import Control.Monad ((>=>))++import Data.Semigroup ((<>))+import qualified Data.Text as T++import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem++data Error where+ ConvertError :: FilePath -> Text -> Error+ MacroError :: FilePath -> SM.Expression -> Text -> Error+ NormalizeError :: FilePath -> Text -> [SM.Expression] -> Error+ ParseError :: FilePath -> Text -> Error+ ProjectError :: Text -> Error++mkFileErrorMsg :: FilePath -> Text -> Text+mkFileErrorMsg (FilePath filePath) err =+ "While compiling '" <> filePath <> "':\n\n" <> err++renderErrorContext :: SM.Expression -> Text+renderErrorContext expr =+ let sourcePosition =+ case getAnn expr of+ Just sp -> ", at " <> SM.renderSourcePosition sp+ Nothing -> ""+ in toAxel expr <> sourcePosition++renderError :: Renderer Error+renderError (ConvertError filePath err) = mkFileErrorMsg filePath err+renderError (MacroError filePath ctxt err) =+ mkFileErrorMsg filePath $+ "While expanding " <> renderErrorContext ctxt <> ":\n\n" <> err+renderError (NormalizeError filePath err context) =+ mkFileErrorMsg filePath $+ err <> "\n\n" <> "Context:\n" <> T.unlines (map renderErrorContext context)+renderError (ParseError filePath err) = mkFileErrorMsg filePath err+renderError (ProjectError err) = err++fatal :: Text -> Text -> a+fatal context message = error $ "[FATAL] " <> context <> " - " <> message++unsafeRunError ::+ Renderer e -> Sem.Sem (Sem.Error e ': effs) a -> Sem.Sem effs a+unsafeRunError render =+ Sem.runError >=> either (errorWithoutStackTrace . render) pure -- TODO Don't(?) use `error(WithoutStackTrace)` directly
src/Axel/Eff/FileSystem.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-} module Axel.Eff.FileSystem where -import Prelude hiding (readFile, writeFile)-import qualified Prelude (writeFile)+import Axel.Prelude import Control.Monad (forM)-import Control.Monad.Freer (type (~>), Eff, LastMember, Member, interpretM)-import Control.Monad.Freer.TH (makeEffect) +import qualified Data.Text as T+import qualified Data.Text.IO as T++import qualified Polysemy as Sem++import Axel.Utils.FilePath ((</>)) import qualified System.Directory ( copyFile , createDirectoryIfMissing@@ -24,45 +24,64 @@ , removeFile , setCurrentDirectory )-import System.FilePath ((</>))-import qualified System.IO.Strict as S (readFile) -data FileSystem a where- CopyFile :: FilePath -> FilePath -> FileSystem ()- CreateDirectoryIfMissing :: Bool -> FilePath -> FileSystem ()- DoesDirectoryExist :: FilePath -> FileSystem Bool- GetCurrentDirectory :: FileSystem FilePath- GetDirectoryContents :: FilePath -> FileSystem [FilePath]- GetTemporaryDirectory :: FileSystem FilePath- ReadFile :: FilePath -> FileSystem String- RemoveFile :: FilePath -> FileSystem ()- SetCurrentDirectory :: FilePath -> FileSystem ()- WriteFile :: String -> FilePath -> FileSystem ()+data FileSystem m a where+ AppendFile :: FilePath -> Text -> FileSystem m ()+ CopyFile :: FilePath -> FilePath -> FileSystem m ()+ CreateDirectoryIfMissing :: Bool -> FilePath -> FileSystem m ()+ DoesDirectoryExist :: FilePath -> FileSystem m Bool+ GetCurrentDirectory :: FileSystem m FilePath+ GetDirectoryContents :: FilePath -> FileSystem m [FilePath]+ GetTemporaryDirectory :: FileSystem m FilePath+ ReadFile :: FilePath -> FileSystem m Text+ RemoveFile :: FilePath -> FileSystem m ()+ SetCurrentDirectory :: FilePath -> FileSystem m ()+ WriteFile :: FilePath -> Text -> FileSystem m () -makeEffect ''FileSystem+Sem.makeSem ''FileSystem -runEff :: (LastMember IO effs) => Eff (FileSystem ': effs) ~> Eff effs-runEff =- interpretM+runFileSystem ::+ (Sem.Member (Sem.Embed IO) effs)+ => Sem.Sem (FileSystem ': effs) a+ -> Sem.Sem effs a+runFileSystem =+ Sem.interpret (\case- CopyFile src dest -> System.Directory.copyFile src dest- CreateDirectoryIfMissing createParentDirs path ->- System.Directory.createDirectoryIfMissing createParentDirs path- DoesDirectoryExist path -> System.Directory.doesDirectoryExist path- GetCurrentDirectory -> System.Directory.getCurrentDirectory- GetDirectoryContents path -> System.Directory.getDirectoryContents path- GetTemporaryDirectory -> System.Directory.getTemporaryDirectory- ReadFile path -> S.readFile path- RemoveFile path -> System.Directory.removeFile path- SetCurrentDirectory path -> System.Directory.setCurrentDirectory path- WriteFile path contents -> Prelude.writeFile path contents)+ 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) -- Adapted from http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html. getDirectoryContentsRec ::- (Member FileSystem effs) => FilePath -> Eff effs [FilePath]+ (Sem.Member FileSystem effs) => FilePath -> Sem.Sem effs [FilePath] getDirectoryContentsRec dir = do names <- getDirectoryContents dir- let properNames = filter (`notElem` [".", ".."]) names+ let properNames =+ filter (\(FilePath path) -> path `notElem` [".", ".."]) names paths <- forM properNames $ \name -> do let path = dir </> name@@ -73,7 +92,10 @@ pure $ concat paths withCurrentDirectory ::- (Member FileSystem effs) => FilePath -> Eff effs a -> Eff effs a+ (Sem.Member FileSystem effs)+ => FilePath+ -> Sem.Sem effs a+ -> Sem.Sem effs a withCurrentDirectory directory f = do originalDirectory <- getCurrentDirectory setCurrentDirectory directory@@ -82,5 +104,7 @@ pure result withTemporaryDirectory ::- (Member FileSystem effs) => (FilePath -> Eff effs a) -> Eff effs a+ (Sem.Member FileSystem effs)+ => (FilePath -> Sem.Sem effs a)+ -> Sem.Sem effs a withTemporaryDirectory action = getTemporaryDirectory >>= action
src/Axel/Eff/Ghci.hs view
@@ -1,28 +1,63 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-} module Axel.Eff.Ghci where -import Control.Monad.Freer (type (~>), Eff, LastMember, interpretM)-import Control.Monad.Freer.TH (makeEffect)+import Axel.Prelude +import Control.Lens (op)+import Control.Monad (void)++import qualified Data.Text as T+ import Language.Haskell.Ghcid (startGhci, stopGhci)-import qualified Language.Haskell.Ghcid as Ghci (Ghci, exec)+import qualified Language.Haskell.Ghcid as Ghci -data Ghci r where- Exec :: Ghci.Ghci -> String -> Ghci [String]- Start :: Ghci Ghci.Ghci- Stop :: Ghci.Ghci -> Ghci ()+import qualified Polysemy as Sem+import qualified Polysemy.Reader as Sem -makeEffect ''Ghci+data Ghci m a where+ Exec :: Ghci.Ghci -> Text -> Ghci m [Text]+ Start :: Ghci m Ghci.Ghci+ Stop :: Ghci.Ghci -> Ghci m () -runEff :: (LastMember IO effs) => Eff (Ghci ': effs) ~> Eff effs-runEff =- interpretM $ \case- Exec ghci command -> Ghci.exec ghci command- Start -> fst <$> startGhci "ghci" Nothing mempty- Stop ghci -> stopGhci ghci+Sem.makeSem ''Ghci++runGhci ::+ (Sem.Member (Sem.Embed IO) effs)+ => Sem.Sem (Ghci ': effs) a+ -> Sem.Sem effs a+runGhci =+ 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++addFiles ::+ (Sem.Member Ghci effs) => Ghci.Ghci -> [FilePath] -> Sem.Sem 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 = void $ exec ghci ":set -ddump-json"++withGhci ::+ (Sem.Member Ghci effs)+ => Sem.Sem (Sem.Reader Ghci.Ghci ': effs) a+ -> Sem.Sem effs a+withGhci x = do+ ghci <- start+ enableJsonErrors ghci+ result <- Sem.runReader ghci x+ stop ghci+ pure result
+ src/Axel/Eff/Lens.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE GADTs #-}++-- NOTE Inspired by `fused-effects-lens`.+module Axel.Eff.Lens where++import Axel.Prelude++import Control.Lens+ ( ASetter+ , ASetter'+ , Const(Const)+ , Const+ , Getting+ , LensLike'+ , (<>~)+ , getConst+ , over+ , set+ )+import qualified Control.Lens.Getter as Lens (view, views)++import Data.Profunctor.Unsafe (Profunctor(( #. )))++import qualified Polysemy as Sem+import qualified Polysemy.Reader as Sem+import qualified Polysemy.State as Sem++{-# INLINE view #-}+view :: (Sem.Member (Sem.Reader s) effs) => Getting a s a -> Sem.Sem effs a+view l = Sem.asks $ getConst #. l Const++{-# INLINE views #-}+views ::+ (Sem.Member (Sem.Reader s) effs)+ => LensLike' (Const r) s a+ -> (a -> r)+ -> Sem.Sem effs r+views l f = Sem.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++{-# INLINE uses #-}+uses ::+ (Sem.Member (Sem.State s) effs)+ => LensLike' (Const r) s a+ -> (a -> r)+ -> Sem.Sem effs r+uses l f = Sem.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++infixr 4 .=++{-# INLINE (.=) #-}+(.=) ::+ (Sem.Member (Sem.State s) effs) => ASetter s s a b -> b -> Sem.Sem 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++infixr 4 %=++{-# INLINE (%=) #-}+(%=) ::+ (Sem.Member (Sem.State s) effs)+ => ASetter s s a b+ -> (a -> b)+ -> Sem.Sem effs ()+(%=) = modifying++{-# INLINE (<>=) #-}+(<>=) ::+ (Sem.Member (Sem.State s) effs, Monoid a)+ => ASetter' s a+ -> a+ -> Sem.Sem effs ()+l <>= a = Sem.modify $ l <>~ a
+ src/Axel/Eff/Log.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Axel.Eff.Log where++import Axel.Prelude++import Axel.Eff.Console (Console, putStr)+import Axel.Eff.FileSystem (FileSystem, appendFile, writeFile)++import qualified Polysemy as Sem++data Log m a where+ LogStr :: Text -> Log m ()++Sem.makeSem ''Log++runLogAsConsole ::+ (Sem.Member Console effs) => Sem.Sem (Log ': effs) a -> Sem.Sem effs a+runLogAsConsole =+ Sem.interpret $ \case+ LogStr str -> putStr str++runLogAsFileSystem ::+ (Sem.Member FileSystem effs)+ => FilePath+ -> Sem.Sem (Log ': effs) a+ -> Sem.Sem effs a+runLogAsFileSystem logFilePath action = do+ writeFile logFilePath ""+ Sem.interpret+ (\case+ LogStr str -> appendFile logFilePath str)+ action++ignoreLog :: Sem.Sem (Log ': effs) a -> Sem.Sem effs a+ignoreLog =+ Sem.interpret $ \case+ LogStr _ -> pure ()++logStrLn :: (Sem.Member Log effs) => Text -> Sem.Sem effs ()+logStrLn str = logStr (str <> "\n")
+ src/Axel/Eff/Loop.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- Inspired by http://www.haskellforall.com/2012/07/breaking-from-loop.html.+module Axel.Eff.Loop where++import Axel.Prelude++import Control.Monad (void)++import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem++type Loop a = Sem.Error a++breakLoop ::+ forall a effs. (Sem.Member (Loop a) effs)+ => a+ -> Sem.Sem effs ()+breakLoop = void . Sem.throw++runLoop :: forall a effs. Sem.Sem (Loop a ': effs) a -> Sem.Sem effs a+runLoop x = either id id <$> Sem.runError x
src/Axel/Eff/Process.hs view
@@ -1,28 +1,31 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} module Axel.Eff.Process where -import Control.Monad.Freer (type (~>), Eff, LastMember, Member, interpretM)-import Control.Monad.Freer.TH (makeEffect)+import Axel.Prelude +import qualified Axel.Utils.Text as T (decodeUtf8Lazy, encodeUtf8Lazy)++import qualified Polysemy as Sem++import Data.Kind (Type) import Data.Singletons (Sing, SingI, sing) import Data.Singletons.TH (singletons)+import qualified Data.Text as T import qualified System.Environment (getArgs) import System.Exit (ExitCode)-import qualified System.Process (readProcessWithExitCode)-import qualified System.Process.Typed (proc, runProcess)+import qualified System.Process.Typed as P+ ( byteStringInput+ , readProcess+ , runProcess+ , setStdin+ , shell+ ) $(singletons [d|@@ -31,10 +34,10 @@ | InheritStreams |]) -type family StreamsHandler (a :: StreamSpecification) (f :: * -> *) :: *+type family StreamsHandler (a :: StreamSpecification) (f :: Type -> Type) :: Type type instance StreamsHandler 'CreateStreams f =- String -> f (ExitCode, String, String)+ Text -> f (ExitCode, Text, Text) type instance StreamsHandler 'InheritStreams f = f ExitCode @@ -42,37 +45,41 @@ = forall streamsHandler. (streamsHandler ~ StreamsHandler streamSpec f) => streamsHandler -type ProcessRunnerPrimitive (streamSpec :: StreamSpecification) (f :: * -> *)- = FilePath -> [String] -> ProcessRunner' streamSpec f+type ProcessRunnerPrimitive (streamSpec :: StreamSpecification) (f :: Type -> Type)+ = FilePath -> [Text] -> ProcessRunner' streamSpec f -type ProcessRunner (streamSpec :: StreamSpecification) (f :: * -> *)+type ProcessRunner (streamSpec :: StreamSpecification) (f :: Type -> Type) = (SingI streamSpec) => ProcessRunner' streamSpec f -data Process r where- GetArgs :: Process [String]- RunProcessCreatingStreams- :: FilePath -> [String] -> String -> Process (ExitCode, String, String)- RunProcessInheritingStreams :: FilePath -> [String] -> Process ExitCode--makeEffect ''Process+data Process m a where+ GetArgs :: Process m [Text]+ RunProcessCreatingStreams :: Text -> Text -> Process m (ExitCode, Text, Text)+ RunProcessInheritingStreams :: Text -> Process m ExitCode -runEff :: (LastMember IO effs) => Eff (Process ': effs) ~> Eff effs-runEff =- interpretM- (\case- GetArgs -> System.Environment.getArgs- RunProcessCreatingStreams cmd args stdin ->- System.Process.readProcessWithExitCode cmd args stdin- RunProcessInheritingStreams cmd args ->- System.Process.Typed.runProcess (System.Process.Typed.proc cmd args))+Sem.makeSem ''Process runProcess ::- forall (streamSpec :: StreamSpecification) effs. (Member Process effs)- => FilePath- -> [String]- -> ProcessRunner streamSpec (Eff effs)-runProcess cmd args =+ (Sem.Member (Sem.Embed IO) effs)+ => Sem.Sem (Process ': effs) a+ -> Sem.Sem effs a+runProcess =+ Sem.interpret $ \case+ GetArgs -> Sem.embed $ map T.pack <$> System.Environment.getArgs+ RunProcessCreatingStreams cmd stdin ->+ Sem.embed $ do+ let stdinStream = P.byteStringInput (T.encodeUtf8Lazy stdin)+ let config = P.setStdin stdinStream $ P.shell (T.unpack cmd)+ (exitCode, stdout, stderr) <- P.readProcess config+ pure (exitCode, T.decodeUtf8Lazy stdout, T.decodeUtf8Lazy stderr)+ RunProcessInheritingStreams cmd ->+ Sem.embed $ P.runProcess (P.shell $ T.unpack cmd)++execProcess ::+ forall (streamSpec :: StreamSpecification) effs. (Sem.Member Process effs)+ => Text+ -> ProcessRunner streamSpec (Sem.Sem effs)+execProcess cmd = case sing :: Sing streamSpec of- SCreateStreams -> runProcessCreatingStreams cmd args- SInheritStreams -> runProcessInheritingStreams cmd args+ SCreateStreams -> runProcessCreatingStreams cmd+ SInheritStreams -> runProcessInheritingStreams cmd
+ src/Axel/Eff/Random.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Axel.Eff.Random where++import Axel.Prelude++import qualified Polysemy as Sem++import qualified System.Random as R++data Random m a where+ Random :: (R.Random a) => Random m a++Sem.makeSem ''Random++runRandom ::+ (Sem.Member (Sem.Embed IO) effs)+ => Sem.Sem (Random ': effs) a+ -> Sem.Sem effs a+runRandom =+ Sem.interpret $ \case+ (Random :: Random m a) -> Sem.embed $ R.randomIO @a
src/Axel/Eff/Resource.hs view
@@ -1,54 +1,48 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-} module Axel.Eff.Resource where +import Axel.Prelude+ import Axel.Eff.FileSystem as FS (FileSystem, readFile)+import Axel.Utils.FilePath ((</>)) +import Control.Lens import Control.Monad ((>=>))-import Control.Monad.Freer (type (~>), Eff, LastMember, Members, interpretM)-import Control.Monad.Freer.TH (makeEffect) -import Paths_axel (getDataFileName)+import Data.Text.Lens (unpacked) -import System.FilePath ((</>))+import qualified Polysemy as Sem +import qualified Paths_axel as Paths (getDataFileName)+ newtype ResourceId =- ResourceId String+ ResourceId Text -data Resource a where- GetResourcePath :: ResourceId -> Resource FilePath+data Resource m a where+ GetResourcePath :: ResourceId -> Resource m FilePath -makeEffect ''Resource+Sem.makeSem ''Resource -runEff :: (LastMember IO effs) => Eff (Resource ': effs) ~> Eff effs-runEff =- interpretM- (\case- GetResourcePath (ResourceId resource) ->- getDataFileName ("resources" </> 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+runResource =+ Sem.interpret $ \case+ GetResourcePath (ResourceId resource) ->+ Sem.embed $ getDataFileName (FilePath "resources" </> FilePath resource)+ readResource ::- (Members '[ FileSystem, Resource] effs) => ResourceId -> Eff effs String+ (Sem.Members '[ FileSystem, Resource] effs)+ => ResourceId+ -> Sem.Sem effs Text readResource = getResourcePath >=> FS.readFile--astDefinition :: ResourceId-astDefinition = ResourceId "autogenerated/macros/AST.hs"--macroDefinitionAndEnvironmentFooter :: ResourceId-macroDefinitionAndEnvironmentFooter =- ResourceId "macros/MacroDefinitionAndEnvironmentFooter.hs"--macroDefinitionAndEnvironmentHeader :: ResourceId-macroDefinitionAndEnvironmentHeader =- ResourceId "macros/MacroDefinitionAndEnvironmentHeader.hs"--macroScaffold :: ResourceId-macroScaffold = ResourceId "macros/Scaffold.hs" newProjectTemplate :: ResourceId newProjectTemplate = ResourceId "new-project-template"
+ src/Axel/Eff/Restartable.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE GADTs #-}++module Axel.Eff.Restartable where++import Axel.Prelude++import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem++type Restartable = Sem.Error++restart :: (Sem.Member (Restartable a) effs) => a -> Sem.Sem effs ()+restart = Sem.throw++runRestartable ::+ a -> (a -> Sem.Sem (Restartable a ': effs) a) -> Sem.Sem effs a+runRestartable x f =+ Sem.runError (f x) >>= \case+ Left x' -> runRestartable x' f+ Right x' -> pure x'
+ src/Axel/Eff/Time.hs view
@@ -0,0 +1,54 @@+{- HLINT ignore "Avoid restricted function" -}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Axel.Eff.Time where++import Axel.Prelude++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++data Time m a where+ GetCurrentTime :: Time m Time.UTCTime++Sem.makeSem ''Time++runTime ::+ (Sem.Member (Sem.Embed IO) effs)+ => Sem.Sem (Time ': effs) a+ -> Sem.Sem effs a+runTime =+ Sem.interpret $ \case+ GetCurrentTime -> Sem.embed Time.getCurrentTime++-- | Only use for debugging purposes.+reportTime ::+ (Sem.Members '[ Effs.Console, Time] effs)+ => Text+ -> Sem.Sem effs a+ -> Sem.Sem effs a+reportTime message x = do+ startTime <- getCurrentTime+ result <- x+ endTime <- getCurrentTime+ let timeDelta =+ let Time.UTCTime currentDay _ = startTime+ timeDiff = Time.diffUTCTime endTime startTime+ utcDelta = Time.UTCTime currentDay (realToFrac timeDiff)+ in T.pack $ Time.formatTime Time.defaultTimeLocale "%S%Q" utcDelta+ Effs.putStrLn $ "\nACTION: " <> message <> "\nTIME: " <> timeDelta <> "\n"+ pure result++unsafeReportTime ::+ Text+ -> Sem.Sem (Time ': Effs.Console ': Sem.Embed IO ': effs) a+ -> Sem.Sem effs a+unsafeReportTime message =+ unsafeEmbedIO . Effs.runConsole . runTime . reportTime message
+ src/Axel/Eff/Unsafe.hs view
@@ -0,0 +1,15 @@+{- HLINT ignore "Avoid restricted function" -}+module Axel.Eff.Unsafe where++import Axel.Prelude++import qualified Polysemy as Sem++import System.IO.Unsafe (unsafePerformIO)++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
− src/Axel/Error.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE TypeOperators #-}--module Axel.Error where--import Axel.Parse.AST (Expression, toAxel)--import Control.Monad ((>=>))-import Control.Monad.Freer (type (~>), Eff, LastMember, send)-import Control.Monad.Freer.Error (runError)-import qualified Control.Monad.Freer.Error as Effs (Error)--import Data.Semigroup ((<>))--data Error- = EvalError String- | MacroError String- | NormalizeError String- [Expression]- | ParseError String- | ProjectError String--instance Show Error where- show :: Error -> String- show (EvalError err) = err- show (MacroError err) = err- show (NormalizeError err context) =- "error:\n" <> err <> "\n\n" <> "context:\n" <> unlines (map toAxel context)- show (ParseError err) = err- show (ProjectError err) = err--fatal :: String -> String -> a-fatal context message = error $ "[FATAL] " <> context <> " - " <> message--runEff :: (Show e, LastMember IO effs) => Eff (Effs.Error e ': effs) ~> Eff effs-runEff =- runError >=> \case- Left err -> send $ ioError $ userError $ show err- Right x -> pure x
+ src/Axel/Haskell/Convert.hs view
@@ -0,0 +1,660 @@+-- 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 #-}++module Axel.Haskell.Convert where++import Axel.Prelude++import qualified Axel.AST as AST+import Axel.Denormalize (denormalizeExpression, denormalizeStatement)+import Axel.Eff.Console (putStrLn)+import qualified Axel.Eff.Console as Effs (Console)+import Axel.Eff.Error (Error(ConvertError), fatal)+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, unsafeHead)+import Axel.Utils.Tuple (flattenAnnotations, unannotated)++import Control.Category ((>>>))+import Control.Lens ((<|), op)+import Control.Lens.Extras (is)+import Control.Lens.Operators ((%~), (^.))++import Data.Data.Lens (biplate, uniplate)+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 Language.Haskell.Exts as HSE++renderRaw :: (HSE.Pretty a) => a -> Text+renderRaw =+ escapeNewlines . escapeQuotes . T.pack . HSE.prettyPrintWithMode ppMode+ where+ ppMode = HSE.defaultMode {HSE.layout = HSE.PPNoLayout}+ escapeQuotes = T.replace "\"" "\\\\\\\""+ escapeNewlines = T.replace "\n" "\\n"++unsupportedExpr :: (HSE.Pretty a) => a -> AST.SMExpression+unsupportedExpr = AST.ERawExpression Nothing . renderRaw++unsupportedStmt :: (HSE.Pretty a) => a -> AST.SMStatement+unsupportedStmt = AST.SRawStatement Nothing . renderRaw++class ToExpr a where+ toExpr :: a b -> AST.SMExpression++class ToStmts a where+ toStmts :: a b -> [AST.SMStatement]++toId :: (ToExpr a) => a b -> Text+toId x =+ let AST.EIdentifier _ sym = toExpr x+ in sym++instance ToExpr HSE.Name where+ toExpr (HSE.Ident _ name) = AST.EIdentifier Nothing $ T.pack name+ toExpr (HSE.Symbol _ name) = AST.EIdentifier Nothing $ T.pack name++instance ToExpr HSE.ModuleName where+ toExpr (HSE.ModuleName _ name) = AST.EIdentifier Nothing $ T.pack name++instance ToExpr HSE.CName where+ toExpr (HSE.VarName _ name) = toExpr name+ toExpr (HSE.ConName _ name) = toExpr name++instance ToExpr HSE.SpecialCon where+ toExpr HSE.UnitCon {} = AST.EIdentifier Nothing "Unit"+ toExpr HSE.ListCon {} = AST.EIdentifier Nothing "List"+ toExpr HSE.FunCon {} = AST.EIdentifier Nothing "->"+ toExpr (HSE.TupleCon _ _ arity) =+ AST.EIdentifier Nothing $ T.replicate arity ","+ toExpr HSE.Cons {} = AST.EIdentifier Nothing ":"+ toExpr expr@HSE.UnboxedSingleCon {} = unsupportedExpr expr+ toExpr HSE.ExprHole {} = AST.EIdentifier Nothing "_"++instance ToExpr HSE.QName where+ toExpr (HSE.Qual _ moduleName name) =+ AST.EIdentifier Nothing $ toId moduleName <> "." <> toId name+ toExpr (HSE.UnQual _ name) = toExpr name+ toExpr (HSE.Special _ specialCon) = toExpr specialCon++instance ToExpr HSE.TyVarBind where+ toExpr (HSE.UnkindedVar _ name) = toExpr name+ toExpr expr@HSE.KindedVar {} = unsupportedExpr expr++instance ToExpr HSE.MaybePromotedName where+ toExpr expr@HSE.PromotedName {} = unsupportedExpr expr+ toExpr (HSE.UnpromotedName _ name) = toExpr name++instance ToExpr HSE.Promoted where+ toExpr expr@HSE.PromotedInteger {} = unsupportedExpr expr+ toExpr expr@HSE.PromotedString {} = unsupportedExpr expr+ toExpr (HSE.PromotedCon _ _ con) = AST.EIdentifier Nothing $ '\'' <| toId con+ toExpr expr@HSE.PromotedList {} = unsupportedExpr expr+ toExpr expr@HSE.PromotedTuple {} = unsupportedExpr expr+ toExpr expr@HSE.PromotedUnit {} = unsupportedExpr expr++instance ToExpr HSE.Type where+ toExpr expr@HSE.TyForall {} = unsupportedExpr expr+ toExpr (HSE.TyFun _ tyA tyB) =+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing "->")+ [toExpr tyA, toExpr tyB]+ toExpr (HSE.TyTuple _ _ tys) =+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing ",")+ (map toExpr tys)+ toExpr expr@HSE.TyUnboxedSum {} = unsupportedExpr expr+ toExpr (HSE.TyList _ ty) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (AST.EIdentifier Nothing "[]") [toExpr ty]+ toExpr expr@HSE.TyParArray {} = unsupportedExpr expr+ toExpr (HSE.TyApp _ tyA tyB) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr tyA) [toExpr tyB]+ toExpr (HSE.TyVar _ x) = toExpr x+ toExpr (HSE.TyCon _ x) = toExpr x+ toExpr (HSE.TyParen _ x) = toExpr x+ toExpr (HSE.TyInfix _ tyA mpn tyB) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr mpn) [toExpr tyA, toExpr tyB]+ toExpr expr@HSE.TyKind {} = unsupportedExpr expr+ toExpr (HSE.TyPromoted _ promoted) = toExpr promoted+ toExpr expr@HSE.TyEquals {} = unsupportedExpr expr+ toExpr expr@HSE.TySplice {} = unsupportedExpr expr+ toExpr expr@HSE.TyBang {} = unsupportedExpr expr+ toExpr (HSE.TyWildCard _ name) =+ AST.EIdentifier Nothing $ "_" <> maybe mempty toId name+ toExpr expr@HSE.TyQuasiQuote {} = unsupportedExpr expr++instance ToExpr HSE.ModuleHead where+ toExpr (HSE.ModuleHead _ name _ _) = toExpr name++instance ToStmts HSE.ModulePragma where+ toStmts (HSE.LanguagePragma _ pragmas) =+ map+ (\pragma -> AST.SPragma . AST.Pragma Nothing $ "LANGUAGE " <> toId pragma)+ pragmas+ toStmts stmt@HSE.OptionsPragma {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.AnnModulePragma {} = [unsupportedStmt stmt]++instance ToStmts HSE.ImportDecl where+ toStmts stmt@(HSE.ImportDecl _ _ _ _ _ _ _ (Just (HSE.ImportSpecList _ True _))) =+ [unsupportedStmt stmt]+ toStmts stmt@(HSE.ImportDecl _ moduleName isQualified _ _ _ alias spec) =+ [ let moduleId = toId moduleName+ in if isQualified+ then case alias of+ Just aliasName ->+ AST.SQualifiedImport $+ AST.QualifiedImport+ Nothing+ moduleId+ (toId aliasName)+ (importSpecListToExpr spec)+ Nothing -> unsupportedStmt stmt+ else case alias of+ Nothing ->+ let importSpec =+ case importSpecListToExpr spec of+ AST.ImportAll _ -> AST.ImportAll Nothing+ AST.ImportOnly _ imports ->+ AST.ImportOnly Nothing imports+ in AST.SRestrictedImport $+ AST.RestrictedImport Nothing moduleId importSpec+ Just _ -> unsupportedStmt stmt+ ]+ where+ importSpecListToExpr Nothing = AST.ImportAll Nothing+ importSpecListToExpr (Just (HSE.ImportSpecList _ False importSpecs)) =+ AST.ImportOnly Nothing $+ map+ (\case+ HSE.IVar _ name -> AST.ImportItem Nothing (toId name)+ HSE.IAbs _ _ name -> AST.ImportItem Nothing (toId name)+ HSE.IThingAll _ name -> AST.ImportType Nothing (toId name) [".."]+ HSE.IThingWith _ name items ->+ AST.ImportType Nothing (toId name) (map toId items))+ importSpecs++instance ToStmts HSE.Module where+ toStmts (HSE.Module _ moduleHead pragmas imports decls) =+ concat+ [ concatMap toStmts pragmas+ , case moduleHead of+ Just moduleId -> [AST.SModuleDeclaration Nothing (toId moduleId)]+ Nothing -> []+ , concatMap toStmts imports+ , concatMap toStmts decls+ ]++instance ToExpr HSE.QualConDecl where+ toExpr (HSE.QualConDecl _ _ _ conDecl) =+ case conDecl of+ HSE.ConDecl _ name args ->+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing $ toId name)+ (map toExpr args)+ HSE.InfixConDecl _ argA name argB ->+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing $ toId name)+ [toExpr argA, toExpr argB]+ HSE.RecDecl {} -> unsupportedExpr conDecl++instance ToExpr HSE.Literal where+ toExpr (HSE.Char _ char _) = AST.ELiteral $ AST.LChar Nothing char+ toExpr (HSE.String _ string _) =+ AST.ELiteral $ AST.LString Nothing $ T.pack string+ toExpr (HSE.Int _ int _) = AST.ELiteral $ AST.LInt Nothing (fromInteger int)+ toExpr expr@HSE.Frac {} = unsupportedExpr expr+ toExpr expr@HSE.PrimInt {} = unsupportedExpr expr+ toExpr expr@HSE.PrimWord {} = unsupportedExpr expr+ toExpr expr@HSE.PrimFloat {} = unsupportedExpr expr+ toExpr expr@HSE.PrimDouble {} = unsupportedExpr expr+ toExpr expr@HSE.PrimChar {} = unsupportedExpr expr+ toExpr expr@HSE.PrimString {} = unsupportedExpr expr++instance ToExpr HSE.Pat where+ toExpr (HSE.PVar _ name) = toExpr name+ toExpr (HSE.PLit _ _ literal) = toExpr literal+ toExpr expr@HSE.PNPlusK {} = unsupportedExpr expr+ toExpr (HSE.PInfixApp _ patA name patB) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr name) [toExpr patA, toExpr patB]+ toExpr (HSE.PApp _ name pats) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr name) (map toExpr pats)+ toExpr (HSE.PTuple _ _ pats) =+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing ",")+ (map toExpr pats)+ toExpr expr@HSE.PUnboxedSum {} = unsupportedExpr expr+ toExpr (HSE.PList _ pats) =+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing "list")+ (map toExpr pats)+ toExpr (HSE.PParen _ pat) = toExpr pat+ toExpr expr@HSE.PRec {} = unsupportedExpr expr+ toExpr expr@HSE.PAsPat {} = unsupportedExpr expr+ toExpr HSE.PWildCard {} = AST.EIdentifier Nothing "_"+ toExpr expr@HSE.PIrrPat {} = unsupportedExpr expr+ toExpr expr@HSE.PatTypeSig {} = unsupportedExpr expr+ toExpr expr@HSE.PViewPat {} = unsupportedExpr expr+ toExpr expr@HSE.PRPat {} = unsupportedExpr expr+ toExpr expr@HSE.PXTag {} = unsupportedExpr expr+ toExpr expr@HSE.PXETag {} = unsupportedExpr expr+ toExpr expr@HSE.PXPcdata {} = unsupportedExpr expr+ toExpr expr@HSE.PXPatTag {} = unsupportedExpr expr+ toExpr expr@HSE.PXRPats {} = unsupportedExpr expr+ toExpr expr@HSE.PSplice {} = unsupportedExpr expr+ toExpr expr@HSE.PQuasiQuote {} = unsupportedExpr expr+ toExpr expr@HSE.PBangPat {} = unsupportedExpr expr++declHeadToTyDef :: HSE.DeclHead a -> AST.TypeDefinition (Maybe SM.Expression)+declHeadToTyDef (HSE.DHead _ name) = AST.ProperType Nothing $ toId name+declHeadToTyDef HSE.DHInfix {} =+ error "Postfix type declarations not supported!"+declHeadToTyDef (HSE.DHParen _ dh) = declHeadToTyDef dh+declHeadToTyDef (HSE.DHApp _ dh tvb) =+ AST.TypeConstructor Nothing $+ case dh of+ HSE.DHInfix _ tvb' name ->+ AST.FunctionApplication Nothing (toExpr name) [toExpr tvb', toExpr tvb]+ _ ->+ AST.FunctionApplication+ Nothing+ (tyDefToExpr $ declHeadToTyDef dh)+ [toExpr tvb]++tyDefToExpr ::+ AST.TypeDefinition (Maybe SM.Expression)+ -> AST.Expression (Maybe SM.Expression)+tyDefToExpr (AST.TypeConstructor _ tyCon) = AST.EFunctionApplication tyCon+tyDefToExpr (AST.ProperType _ ty) = AST.EIdentifier Nothing ty++exprToTyDef ::+ AST.Expression (Maybe SM.Expression)+ -> AST.TypeDefinition (Maybe SM.Expression)+exprToTyDef (AST.EIdentifier _ identifier) = AST.ProperType Nothing identifier+exprToTyDef (AST.EFunctionApplication funApp) =+ AST.TypeConstructor Nothing funApp++toFunApp ::+ AST.Expression (Maybe SM.Expression)+ -> AST.FunctionApplication (Maybe SM.Expression)+toFunApp (AST.EFunctionApplication funApp) = funApp+toFunApp (AST.EIdentifier _ sym) =+ AST.FunctionApplication Nothing (AST.EIdentifier Nothing sym) []++bindsToFunDefs ::+ Maybe (HSE.Binds a) -> [AST.FunctionDefinition (Maybe SM.Expression)]+bindsToFunDefs Nothing = []+bindsToFunDefs (Just (HSE.BDecls _ decls)) =+ map+ (\decl ->+ case toStmts decl of+ [AST.SFunctionDefinition funDef] -> funDef)+ decls+bindsToFunDefs (Just HSE.IPBinds {}) =+ error "Implicit parameters not supported!"++altToClause ::+ HSE.Alt a+ -> ( AST.Expression (Maybe SM.Expression)+ , AST.Expression (Maybe SM.Expression))+altToClause (HSE.Alt _ pat rhs _) = (toExpr pat, toExpr rhs)++instance ToExpr HSE.QOp where+ toExpr (HSE.QVarOp _ name) = toExpr name+ toExpr (HSE.QConOp _ name) = toExpr name++instance ToExpr HSE.Exp where+ toExpr (HSE.Var _ name) = toExpr name+ toExpr expr@HSE.OverloadedLabel {} = unsupportedExpr expr+ toExpr expr@HSE.IPVar {} = unsupportedExpr expr+ toExpr (HSE.Con _ name) = toExpr name+ toExpr (HSE.Lit _ lit) = toExpr lit+ toExpr (HSE.InfixApp _ a op' b) =+ if toId op' == "$"+ then AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr a) [toExpr b]+ else AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing "applyInfix")+ [toExpr a, toExpr op', toExpr b]+ toExpr (HSE.App _ (HSE.App _ f a) b) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr f) [toExpr a, toExpr b]+ toExpr (HSE.App _ f x) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr f) [toExpr x]+ toExpr expr@HSE.NegApp {} = unsupportedExpr expr+ toExpr (HSE.Lambda _ args body) =+ AST.ELambda $ AST.Lambda Nothing (map toExpr args) (toExpr body)+ toExpr (HSE.Let _ binds body) =+ AST.ELetBlock $ AST.LetBlock Nothing (bindsToClauses binds) (toExpr body)+ toExpr (HSE.If _ cond ifTrue ifFalse) =+ AST.EIfBlock $+ AST.IfBlock Nothing (toExpr cond) (toExpr ifTrue) (toExpr ifFalse)+ toExpr expr@HSE.MultiIf {} = unsupportedExpr expr+ toExpr (HSE.Case _ expr matches) =+ AST.ECaseBlock $+ AST.CaseBlock Nothing (toExpr expr) (map altToClause matches)+ toExpr (HSE.Do _ stmts) =+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing "do'")+ (map handleStmt stmts)+ where+ handleStmt (HSE.Generator _ pat expr) =+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing "<-")+ [toExpr pat, toExpr expr]+ handleStmt (HSE.Qualifier _ expr) = toExpr expr+ handleStmt (HSE.LetStmt _ binds) =+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing "let")+ (map handleClause $ bindsToClauses binds)+ handleClause (var, val) =+ AST.EFunctionApplication $ AST.FunctionApplication Nothing var [val]+ toExpr expr@HSE.MDo {} = unsupportedExpr expr+ toExpr (HSE.Tuple _ _ exps) =+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing $ T.replicate (length exps) ",")+ (map toExpr exps)+ toExpr expr@HSE.UnboxedSum {} = unsupportedExpr expr+ toExpr expr@HSE.TupleSection {} = unsupportedExpr expr+ toExpr (HSE.List _ items) =+ AST.EFunctionApplication $+ AST.FunctionApplication+ Nothing+ (AST.EIdentifier Nothing "list")+ (map toExpr items)+ toExpr expr@HSE.ParArray {} = unsupportedExpr expr+ toExpr (HSE.Paren _ expr) = toExpr expr+ toExpr expr@HSE.LeftSection {} = unsupportedExpr expr+ toExpr expr@HSE.RightSection {} = unsupportedExpr expr+ toExpr expr@HSE.RecConstr {} = unsupportedExpr expr+ toExpr expr@HSE.RecUpdate {} = unsupportedExpr expr+ toExpr expr@HSE.EnumFrom {} = unsupportedExpr expr+ toExpr expr@HSE.EnumFromTo {} = unsupportedExpr expr+ toExpr expr@HSE.EnumFromThen {} = unsupportedExpr expr+ toExpr expr@HSE.EnumFromThenTo {} = unsupportedExpr expr+ toExpr expr@HSE.ListComp {} = unsupportedExpr expr+ toExpr expr@HSE.ParComp {} = unsupportedExpr expr+ toExpr expr@HSE.ParArrayComp {} = unsupportedExpr expr+ toExpr expr@HSE.ParArrayFromTo {} = unsupportedExpr expr+ toExpr expr@HSE.ParArrayFromThenTo {} = unsupportedExpr expr+ toExpr expr@HSE.ExpTypeSig {} = unsupportedExpr expr+ toExpr expr@HSE.VarQuote {} = unsupportedExpr expr+ toExpr expr@HSE.TypQuote {} = unsupportedExpr expr+ toExpr expr@HSE.BracketExp {} = unsupportedExpr expr+ toExpr expr@HSE.SpliceExp {} = unsupportedExpr expr+ toExpr expr@HSE.QuasiQuote {} = unsupportedExpr expr+ toExpr expr@HSE.TypeApp {} = unsupportedExpr expr+ toExpr expr@HSE.XTag {} = unsupportedExpr expr+ toExpr expr@HSE.XETag {} = unsupportedExpr expr+ toExpr expr@HSE.XPcdata {} = unsupportedExpr expr+ toExpr expr@HSE.XExpTag {} = unsupportedExpr expr+ toExpr expr@HSE.XChildTag {} = unsupportedExpr expr+ toExpr expr@HSE.CorePragma {} = unsupportedExpr expr+ toExpr expr@HSE.SCCPragma {} = unsupportedExpr expr+ toExpr expr@HSE.GenPragma {} = unsupportedExpr expr+ toExpr expr@HSE.Proc {} = unsupportedExpr expr+ toExpr expr@HSE.LeftArrApp {} = unsupportedExpr expr+ toExpr expr@HSE.RightArrApp {} = unsupportedExpr expr+ toExpr expr@HSE.LeftArrHighApp {} = unsupportedExpr expr+ toExpr expr@HSE.RightArrHighApp {} = unsupportedExpr expr+ toExpr expr@HSE.LCase {} = unsupportedExpr expr++instance ToExpr HSE.Rhs where+ toExpr (HSE.UnGuardedRhs _ expr) = toExpr expr+ toExpr expr@HSE.GuardedRhss {} = unsupportedExpr expr++bindsToClauses ::+ HSE.Binds a+ -> [( AST.Expression (Maybe SM.Expression)+ , AST.Expression (Maybe SM.Expression))]+bindsToClauses (HSE.BDecls _ decls) =+ map (\(HSE.PatBind _ pat body _) -> (toExpr pat, toExpr body)) decls++instance ToStmts HSE.Match where+ toStmts (HSE.Match _ fn pats body whereBinds) =+ [ AST.SFunctionDefinition $+ AST.FunctionDefinition+ Nothing+ (toId fn)+ (map toExpr pats)+ (toExpr body)+ (bindsToFunDefs whereBinds)+ ]+ toStmts (HSE.InfixMatch _ pat fn pats body whereBinds) =+ [ AST.SFunctionDefinition $+ AST.FunctionDefinition+ Nothing+ (toId fn)+ (toExpr pat : map toExpr pats)+ (toExpr body)+ (bindsToFunDefs whereBinds)+ ]++instance ToExpr HSE.InstHead where+ toExpr (HSE.IHCon _ name) = toExpr name+ toExpr (HSE.IHInfix _ ty name) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr ty) [toExpr name]+ toExpr (HSE.IHParen _ instHead) = toExpr instHead+ toExpr (HSE.IHApp _ instHead ty) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr instHead) [toExpr ty]++instance ToExpr HSE.InstRule where+ toExpr (HSE.IRule _ _ Nothing instHead) = toExpr instHead+ toExpr (HSE.IParen _ rule) = toExpr rule++instance ToStmts HSE.Decl where+ toStmts (HSE.TypeDecl _ declHead ty) =+ [ AST.STypeSynonym $+ AST.TypeSynonym+ Nothing+ (tyDefToExpr $ declHeadToTyDef declHead)+ (toExpr ty)+ ]+ toStmts stmt@HSE.TypeFamDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.ClosedTypeFamDecl {} = [unsupportedStmt stmt]+ toStmts (HSE.DataDecl _ dataOrNew _ declHead cases _) =+ [ case dataOrNew of+ HSE.NewType _ ->+ AST.SNewtypeDeclaration $+ AST.NewtypeDeclaration+ Nothing+ (declHeadToTyDef declHead)+ (toFunApp $ toExpr $ unsafeHead cases)+ HSE.DataType _ ->+ AST.SDataDeclaration $+ AST.DataDeclaration+ Nothing+ (declHeadToTyDef declHead)+ (map (toFunApp . toExpr) cases)+ ]+ toStmts stmt@HSE.GDataDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.DataFamDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.TypeInsDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.DataInsDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.GDataInsDecl {} = [unsupportedStmt stmt]+ toStmts (HSE.ClassDecl _ ctxt declHead _ decls) =+ [ AST.STypeclassDefinition $+ AST.TypeclassDefinition+ Nothing+ (tyDefToExpr $ declHeadToTyDef declHead)+ (contextToExprs ctxt)+ (maybe [] (map classDeclToTySig) decls)+ ]+ toStmts (HSE.InstDecl _ _ rule decls) =+ [ AST.STypeclassInstance $+ AST.TypeclassInstance+ Nothing+ (toExpr rule)+ (maybe [] (map instDeclToFunDef) decls)+ ]+ toStmts stmt@HSE.DerivDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.InfixDecl {} = [unsupportedStmt stmt]+ toStmts (HSE.TypeSig _ names ty) =+ map+ (\name ->+ AST.STypeSignature $ AST.TypeSignature Nothing (toId name) (toExpr ty))+ names+ toStmts stmt@HSE.PatSynSig {} = [unsupportedStmt stmt]+ toStmts (HSE.FunBind _ cases) = concatMap toStmts cases+ toStmts (HSE.PatBind _ fn body whereBinds) =+ [ AST.SFunctionDefinition $+ AST.FunctionDefinition+ Nothing+ (toId fn)+ []+ (toExpr body)+ (bindsToFunDefs whereBinds)+ ]+ toStmts stmt@HSE.ForImp {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.ForExp {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.RulePragmaDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.DeprPragmaDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.WarnPragmaDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.InlineSig {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.InlineConlikeSig {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.SpecSig {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.SpecInlineSig {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.InstSig {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.AnnPragma {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.MinimalPragma {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.RoleAnnotDecl {} = [unsupportedStmt stmt]+ toStmts stmt@HSE.CompletePragma {} = [unsupportedStmt stmt]++instDeclToFunDef ::+ HSE.InstDecl a -> AST.FunctionDefinition (Maybe SM.Expression)+instDeclToFunDef (HSE.InsDecl _ decl) =+ case unsafeHead $ toStmts decl of+ AST.SFunctionDefinition funDef -> funDef+instDeclToFunDef HSE.InsType {} = error "Type families not supported!"+instDeclToFunDef HSE.InsData {} = error "Type families not supported!"+instDeclToFunDef HSE.InsGData {} = error "Type families not supported!"++classDeclToTySig :: HSE.ClassDecl a -> AST.TypeSignature (Maybe SM.Expression)+classDeclToTySig (HSE.ClsDecl _ decl) =+ case toStmts decl of+ [AST.STypeSignature tySig] -> tySig+classDeclToTySig HSE.ClsDataFam {} = error "Type families not supported!"+classDeclToTySig HSE.ClsTyFam {} = error "Type families not supported!"+classDeclToTySig HSE.ClsTyDef {} = error "Type families not supported!"+classDeclToTySig HSE.ClsDefSig {} = error "Default signatures not supported!"++instance ToExpr HSE.Asst where+ toExpr (HSE.ClassA _ name tys) =+ AST.EFunctionApplication $+ AST.FunctionApplication Nothing (toExpr name) (map toExpr tys)+ toExpr (HSE.WildCardA _ _) = AST.EIdentifier Nothing "_"++contextToExprs ::+ Maybe (HSE.Context a) -> [AST.Expression (Maybe SM.Expression)]+contextToExprs Nothing = []+contextToExprs (Just (HSE.CxSingle _ asst)) = [toExpr asst]+contextToExprs (Just (HSE.CxTuple _ assts)) = map toExpr assts+contextToExprs (Just (HSE.CxEmpty _)) = []++convertFile ::+ (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error, Effs.FileSystem] effs)+ => FilePath+ -> FilePath+ -> Sem.Sem 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)+ putStrLn $ "Writing " <> op FilePath newPath <> "..."+ let newContents =+ prettifyProgram $+ groupFunctionDefinitions $+ flattenFunctionApplications $ toStmts parsedModule+ FS.writeFile newPath newContents+ pure newPath++flattenFunctionApplications :: [AST.SMStatement] -> [AST.SMStatement]+flattenFunctionApplications = map (biplate %~ (uniplate %~ handleExpr))+ where+ handleExpr :: AST.SMExpression -> AST.SMExpression+ 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 . AST.SFunctionDefinition)+ (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)) ->+ case maybeFnName of+ Nothing -> map denormalizeStatement stmts+ Just fnName ->+ case tySigs of+ [AST.STypeSignature tySig] ->+ [ 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/Converter.hs
@@ -1,502 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeOperators #-}--module Axel.Haskell.Converter where--import Prelude hiding (putStrLn)--import qualified Axel.AST as AST-import Axel.Denormalize (denormalizeStatement)-import Axel.Eff.Console (putStrLn)-import qualified Axel.Eff.Console as Effs (Console)-import qualified Axel.Eff.FileSystem as Effs (FileSystem)-import qualified Axel.Eff.FileSystem as FS (writeFile)-import Axel.Parse.AST (toAxel)-import Axel.Utils.String (replace)--import Control.Lens.Operators ((<&>))-import Control.Monad.Freer (Eff, LastMember, Members, sendM)--import qualified Language.Haskell.Exts as HSE--renderRaw :: (HSE.Pretty a) => a -> String-renderRaw = escapeNewlines . escapeQuotes . HSE.prettyPrintWithMode ppMode- where- ppMode = HSE.defaultMode {HSE.layout = HSE.PPNoLayout}- escapeQuotes = replace "\"" "\\\""- escapeNewlines = replace "\n" "\\n"--unsupportedExpr :: (HSE.Pretty a) => a -> AST.Expression-unsupportedExpr = AST.ERawExpression . renderRaw--unsupportedStmt :: (HSE.Pretty a) => a -> AST.Statement-unsupportedStmt = AST.SRawStatement . renderRaw--class ToExpr a where- toExpr :: a b -> AST.Expression--class ToStmts a where- toStmts :: a b -> [AST.Statement]--toId :: (ToExpr a) => a b -> String-toId x =- let AST.EIdentifier sym = toExpr x- in sym--instance ToExpr HSE.Name where- toExpr (HSE.Ident _ name) = AST.EIdentifier name- toExpr (HSE.Symbol _ name) = AST.EIdentifier name--instance ToExpr HSE.ModuleName where- toExpr (HSE.ModuleName _ name) = AST.EIdentifier name--instance ToExpr HSE.CName where- toExpr (HSE.VarName _ name) = toExpr name- toExpr (HSE.ConName _ name) = toExpr name--instance ToExpr HSE.SpecialCon where- toExpr HSE.UnitCon {} = AST.EIdentifier "Unit"- toExpr HSE.ListCon {} = AST.EIdentifier "List"- toExpr HSE.FunCon {} = AST.EIdentifier "->"- toExpr (HSE.TupleCon _ _ arity) = AST.EIdentifier $ replicate arity ','- toExpr HSE.Cons {} = AST.EIdentifier ":"- toExpr expr@HSE.UnboxedSingleCon {} = unsupportedExpr expr- toExpr HSE.ExprHole {} = AST.EIdentifier "_"--instance ToExpr HSE.QName where- toExpr (HSE.Qual _ moduleName name) =- AST.EIdentifier $ toId moduleName <> "." <> toId name- toExpr (HSE.UnQual _ name) = toExpr name- toExpr (HSE.Special _ specialCon) = toExpr specialCon--instance ToExpr HSE.TyVarBind where- toExpr (HSE.UnkindedVar _ name) = toExpr name- toExpr expr@HSE.KindedVar {} = unsupportedExpr expr--instance ToExpr HSE.MaybePromotedName where- toExpr expr@HSE.PromotedName {} = unsupportedExpr expr- toExpr (HSE.UnpromotedName _ name) = toExpr name--instance ToExpr HSE.Promoted where- toExpr expr@HSE.PromotedInteger {} = unsupportedExpr expr- toExpr expr@HSE.PromotedString {} = unsupportedExpr expr- toExpr (HSE.PromotedCon _ _ con) = AST.EIdentifier $ '\'' : toId con- toExpr (HSE.PromotedList _ _ list) =- AST.EFunctionApplication $- AST.FunctionApplication (AST.EIdentifier "list") (map toExpr list)- toExpr expr@HSE.PromotedTuple {} = unsupportedExpr expr- toExpr expr@HSE.PromotedUnit {} = unsupportedExpr expr--instance ToExpr HSE.Type where- toExpr expr@HSE.TyForall {} = unsupportedExpr expr- toExpr (HSE.TyFun _ tyA tyB) =- AST.EFunctionApplication $ AST.FunctionApplication (AST.EIdentifier "->") [toExpr tyA, toExpr tyB]- toExpr (HSE.TyTuple _ _ tys) =- AST.EFunctionApplication $- AST.FunctionApplication (AST.EIdentifier ",") (map toExpr tys)- toExpr expr@HSE.TyUnboxedSum {} = unsupportedExpr expr- toExpr (HSE.TyList _ ty) =- AST.EFunctionApplication $- AST.FunctionApplication (AST.EIdentifier "[]") [toExpr ty]- toExpr expr@HSE.TyParArray {} = unsupportedExpr expr- toExpr (HSE.TyApp _ tyA tyB) =- AST.EFunctionApplication $ AST.FunctionApplication (toExpr tyA) [toExpr tyB]- toExpr (HSE.TyVar _ x) = toExpr x- toExpr (HSE.TyCon _ x) = toExpr x- toExpr (HSE.TyParen _ x) = toExpr x- toExpr (HSE.TyInfix _ tyA mpn tyB) =- AST.EFunctionApplication $- AST.FunctionApplication (toExpr mpn) [toExpr tyA, toExpr tyB]- toExpr expr@HSE.TyKind {} = unsupportedExpr expr- toExpr (HSE.TyPromoted _ promoted) = toExpr promoted- toExpr expr@HSE.TyEquals {} = unsupportedExpr expr- toExpr expr@HSE.TySplice {} = unsupportedExpr expr- toExpr expr@HSE.TyBang {} = unsupportedExpr expr- toExpr (HSE.TyWildCard _ name) =- AST.EIdentifier $ "_" <> maybe mempty toId name- toExpr expr@HSE.TyQuasiQuote {} = unsupportedExpr expr--instance ToExpr HSE.ModuleHead where- toExpr (HSE.ModuleHead _ name _ _) = toExpr name--instance ToStmts HSE.ModulePragma where- toStmts (HSE.LanguagePragma _ pragmas) =- map- (\pragma -> AST.SPragma . AST.Pragma $ "LANGUAGE " <> toId pragma)- pragmas- toStmts stmt@HSE.OptionsPragma {} = [unsupportedStmt stmt]- toStmts stmt@HSE.AnnModulePragma {} = [unsupportedStmt stmt]--instance ToStmts HSE.ImportDecl where- toStmts stmt@(HSE.ImportDecl _ _ _ _ _ _ _ (Just (HSE.ImportSpecList _ True _))) =- [unsupportedStmt stmt]- toStmts stmt@(HSE.ImportDecl _ moduleName isQualified _ _ _ alias spec) =- [ let moduleId = toId moduleName- in if isQualified- then case alias of- Just aliasName ->- AST.SQualifiedImport $- AST.QualifiedImport- moduleId- (toId aliasName)- (importSpecListToExpr spec)- Nothing -> unsupportedStmt stmt- else case alias of- Nothing ->- case importSpecListToExpr spec of- AST.ImportAll -> AST.SUnrestrictedImport moduleId- AST.ImportOnly imports ->- AST.SRestrictedImport $- AST.RestrictedImport moduleId (AST.ImportOnly imports)- Just _ -> unsupportedStmt stmt- ]- where- importSpecListToExpr Nothing = AST.ImportAll- importSpecListToExpr (Just (HSE.ImportSpecList _ False importSpecs)) =- AST.ImportOnly $- map- (\case- HSE.IVar _ name -> AST.ImportItem (toId name)- HSE.IAbs _ _ name -> AST.ImportItem (toId name)- HSE.IThingAll _ name -> AST.ImportType (toId name) [".."]- HSE.IThingWith _ name items ->- AST.ImportType (toId name) (map toId items))- importSpecs--instance ToStmts HSE.Module where- toStmts (HSE.Module _ moduleHead pragmas imports decls) =- concat- [ concatMap toStmts pragmas- , case moduleHead of- Just moduleId -> [AST.SModuleDeclaration (toId moduleId)]- Nothing -> []- , concatMap toStmts imports- , concatMap toStmts decls- ]--instance ToExpr HSE.QualConDecl where- toExpr (HSE.QualConDecl _ _ _ conDecl) =- case conDecl of- HSE.ConDecl _ name args ->- AST.EFunctionApplication $- AST.FunctionApplication (AST.EIdentifier $ toId name) (map toExpr args)- HSE.InfixConDecl _ argA name argB ->- AST.EFunctionApplication $- AST.FunctionApplication- (AST.EIdentifier $ toId name)- [toExpr argA, toExpr argB]- HSE.RecDecl {} -> unsupportedExpr conDecl--instance ToExpr HSE.Literal where- toExpr (HSE.Char _ char _) = AST.ELiteral $ AST.LChar char- toExpr (HSE.String _ string _) = AST.ELiteral $ AST.LString string- toExpr (HSE.Int _ int _) = AST.ELiteral $ AST.LInt (fromInteger int)- toExpr expr@HSE.Frac {} = unsupportedExpr expr- toExpr expr@HSE.PrimInt {} = unsupportedExpr expr- toExpr expr@HSE.PrimWord {} = unsupportedExpr expr- toExpr expr@HSE.PrimFloat {} = unsupportedExpr expr- toExpr expr@HSE.PrimDouble {} = unsupportedExpr expr- toExpr expr@HSE.PrimChar {} = unsupportedExpr expr- toExpr expr@HSE.PrimString {} = unsupportedExpr expr--instance ToExpr HSE.Pat where- toExpr (HSE.PVar _ name) = toExpr name- toExpr (HSE.PLit _ _ literal) = toExpr literal- toExpr expr@HSE.PNPlusK {} = unsupportedExpr expr- toExpr (HSE.PInfixApp _ patA name patB) =- AST.EFunctionApplication $- AST.FunctionApplication (toExpr name) [toExpr patA, toExpr patB]- toExpr (HSE.PApp _ name pats) =- AST.EFunctionApplication $- AST.FunctionApplication (toExpr name) (map toExpr pats)- toExpr (HSE.PTuple _ _ pats) =- AST.EFunctionApplication $- AST.FunctionApplication (AST.EIdentifier ",") (map toExpr pats)- toExpr expr@HSE.PUnboxedSum {} = unsupportedExpr expr- toExpr (HSE.PList _ pats) =- AST.EFunctionApplication $- AST.FunctionApplication (AST.EIdentifier "list") (map toExpr pats)- toExpr (HSE.PParen _ pat) = toExpr pat- toExpr expr@HSE.PRec {} = unsupportedExpr expr- toExpr expr@HSE.PAsPat {} = unsupportedExpr expr- toExpr HSE.PWildCard {} = AST.EIdentifier "_"- toExpr expr@HSE.PIrrPat {} = unsupportedExpr expr- toExpr expr@HSE.PatTypeSig {} = unsupportedExpr expr- toExpr expr@HSE.PViewPat {} = unsupportedExpr expr- toExpr expr@HSE.PRPat {} = unsupportedExpr expr- toExpr expr@HSE.PXTag {} = unsupportedExpr expr- toExpr expr@HSE.PXETag {} = unsupportedExpr expr- toExpr expr@HSE.PXPcdata {} = unsupportedExpr expr- toExpr expr@HSE.PXPatTag {} = unsupportedExpr expr- toExpr expr@HSE.PXRPats {} = unsupportedExpr expr- toExpr expr@HSE.PSplice {} = unsupportedExpr expr- toExpr expr@HSE.PQuasiQuote {} = unsupportedExpr expr- toExpr expr@HSE.PBangPat {} = unsupportedExpr expr--declHeadToTyDef :: HSE.DeclHead a -> AST.TypeDefinition-declHeadToTyDef (HSE.DHead _ name) = AST.ProperType $ toId name-declHeadToTyDef HSE.DHInfix {} =- error "Postfix type declarations not supported!"-declHeadToTyDef (HSE.DHParen _ dh) = declHeadToTyDef dh-declHeadToTyDef (HSE.DHApp _ dh tvb) =- AST.TypeConstructor $- case dh of- HSE.DHInfix _ tvb' name ->- AST.FunctionApplication (toExpr name) [toExpr tvb', toExpr tvb]- _ -> AST.FunctionApplication (tyDefToExpr $ declHeadToTyDef dh) [toExpr tvb]--tyDefToExpr :: AST.TypeDefinition -> AST.Expression-tyDefToExpr (AST.TypeConstructor tyCon) = AST.EFunctionApplication tyCon-tyDefToExpr (AST.ProperType ty) = AST.EIdentifier ty--exprToTyDef :: AST.Expression -> AST.TypeDefinition-exprToTyDef (AST.EIdentifier identifier) = AST.ProperType identifier-exprToTyDef (AST.EFunctionApplication funApp) = AST.TypeConstructor funApp--toFunApp :: AST.Expression -> AST.FunctionApplication-toFunApp (AST.EFunctionApplication funApp) = funApp-toFunApp (AST.EIdentifier sym) =- AST.FunctionApplication (AST.EIdentifier sym) []--bindsToFunDefs :: Maybe (HSE.Binds a) -> [AST.FunctionDefinition]-bindsToFunDefs Nothing = []-bindsToFunDefs (Just (HSE.BDecls _ decls)) =- map- (\decl ->- case toStmts decl of- [AST.SFunctionDefinition funDef] -> funDef)- decls-bindsToFunDefs (Just HSE.IPBinds {}) =- error "Implicit parameters not supported!"--altToClause :: HSE.Alt a -> (AST.Expression, AST.Expression)-altToClause (HSE.Alt _ pat rhs _) = (toExpr pat, toExpr rhs)--instance ToExpr HSE.QOp where- toExpr (HSE.QVarOp _ name) = toExpr name- toExpr (HSE.QConOp _ name) = toExpr name--instance ToExpr HSE.Exp where- toExpr (HSE.Var _ name) = toExpr name- toExpr expr@HSE.OverloadedLabel {} = unsupportedExpr expr- toExpr expr@HSE.IPVar {} = unsupportedExpr expr- toExpr (HSE.Con _ name) = toExpr name- toExpr (HSE.Lit _ lit) = toExpr lit- toExpr (HSE.InfixApp _ a op b) =- AST.EFunctionApplication $- AST.FunctionApplication (AST.EIdentifier "infixApply") [toExpr a, toExpr op, toExpr b]- toExpr (HSE.App _ f x) =- AST.EFunctionApplication $ AST.FunctionApplication (toExpr f) [toExpr x]- toExpr expr@HSE.NegApp {} = unsupportedExpr expr- toExpr (HSE.Lambda _ args body) =- AST.ELambda $ AST.Lambda (map toExpr args) (toExpr body)- toExpr (HSE.Let _ binds body) =- AST.ELetBlock $ AST.LetBlock (bindsToClauses binds) (toExpr body)- toExpr (HSE.If _ cond ifTrue ifFalse) =- AST.EIfBlock $ AST.IfBlock (toExpr cond) (toExpr ifTrue) (toExpr ifFalse)- toExpr expr@HSE.MultiIf {} = unsupportedExpr expr- toExpr (HSE.Case _ expr matches) =- AST.ECaseBlock $ AST.CaseBlock (toExpr expr) (map altToClause matches)- toExpr expr@HSE.Do {} = unsupportedExpr expr- toExpr expr@HSE.MDo {} = unsupportedExpr expr- toExpr (HSE.Tuple _ _ exps) =- AST.EFunctionApplication $- AST.FunctionApplication- (AST.EIdentifier $ replicate (length exps) ',')- (map toExpr exps)- toExpr expr@HSE.UnboxedSum {} = unsupportedExpr expr- toExpr expr@HSE.TupleSection {} = unsupportedExpr expr- toExpr (HSE.List _ items) =- AST.EFunctionApplication $- AST.FunctionApplication (AST.EIdentifier "list") (map toExpr items)- toExpr expr@HSE.ParArray {} = unsupportedExpr expr- toExpr (HSE.Paren _ expr) = toExpr expr- toExpr expr@HSE.LeftSection {} = unsupportedExpr expr- toExpr expr@HSE.RightSection {} = unsupportedExpr expr- toExpr expr@HSE.RecConstr {} = unsupportedExpr expr- toExpr expr@HSE.RecUpdate {} = unsupportedExpr expr- toExpr expr@HSE.EnumFrom {} = unsupportedExpr expr- toExpr expr@HSE.EnumFromTo {} = unsupportedExpr expr- toExpr expr@HSE.EnumFromThen {} = unsupportedExpr expr- toExpr expr@HSE.EnumFromThenTo {} = unsupportedExpr expr- toExpr expr@HSE.ListComp {} = unsupportedExpr expr- toExpr expr@HSE.ParComp {} = unsupportedExpr expr- toExpr expr@HSE.ParArrayComp {} = unsupportedExpr expr- toExpr expr@HSE.ParArrayFromTo {} = unsupportedExpr expr- toExpr expr@HSE.ParArrayFromThenTo {} = unsupportedExpr expr- toExpr expr@HSE.ExpTypeSig {} = unsupportedExpr expr- toExpr expr@HSE.VarQuote {} = unsupportedExpr expr- toExpr expr@HSE.TypQuote {} = unsupportedExpr expr- toExpr expr@HSE.BracketExp {} = unsupportedExpr expr- toExpr expr@HSE.SpliceExp {} = unsupportedExpr expr- toExpr expr@HSE.QuasiQuote {} = unsupportedExpr expr- toExpr expr@HSE.TypeApp {} = unsupportedExpr expr- toExpr expr@HSE.XTag {} = unsupportedExpr expr- toExpr expr@HSE.XETag {} = unsupportedExpr expr- toExpr expr@HSE.XPcdata {} = unsupportedExpr expr- toExpr expr@HSE.XExpTag {} = unsupportedExpr expr- toExpr expr@HSE.XChildTag {} = unsupportedExpr expr- toExpr expr@HSE.CorePragma {} = unsupportedExpr expr- toExpr expr@HSE.SCCPragma {} = unsupportedExpr expr- toExpr expr@HSE.GenPragma {} = unsupportedExpr expr- toExpr expr@HSE.Proc {} = unsupportedExpr expr- toExpr expr@HSE.LeftArrApp {} = unsupportedExpr expr- toExpr expr@HSE.RightArrApp {} = unsupportedExpr expr- toExpr expr@HSE.LeftArrHighApp {} = unsupportedExpr expr- toExpr expr@HSE.RightArrHighApp {} = unsupportedExpr expr- toExpr expr@HSE.LCase {} = unsupportedExpr expr--instance ToExpr HSE.Rhs where- toExpr (HSE.UnGuardedRhs _ expr) = toExpr expr- toExpr expr@HSE.GuardedRhss {} = unsupportedExpr expr--bindsToClauses :: HSE.Binds a -> [(AST.Expression, AST.Expression)]-bindsToClauses (HSE.BDecls _ decls) =- map (\(HSE.PatBind _ pat body _) -> (toExpr pat, toExpr body)) decls--instance ToStmts HSE.Match where- toStmts (HSE.Match _ fn pats body whereBinds) =- [ AST.SFunctionDefinition $- AST.FunctionDefinition- (toId fn)- (map toExpr pats)- (toExpr body)- (bindsToFunDefs whereBinds)- ]- toStmts (HSE.InfixMatch _ pat fn pats body whereBinds) =- [ AST.SFunctionDefinition $- AST.FunctionDefinition- (toId fn)- (toExpr pat : map toExpr pats)- (toExpr body)- (bindsToFunDefs whereBinds)- ]--instance ToExpr HSE.InstHead where- toExpr (HSE.IHCon _ name) = toExpr name- toExpr (HSE.IHInfix _ ty name) =- AST.EFunctionApplication $ AST.FunctionApplication (toExpr ty) [toExpr name]- toExpr (HSE.IHParen _ instHead) = toExpr instHead- toExpr (HSE.IHApp _ instHead ty) =- AST.EFunctionApplication $- AST.FunctionApplication (toExpr instHead) [toExpr ty]--instance ToExpr HSE.InstRule where- toExpr (HSE.IRule _ _ Nothing instHead) = toExpr instHead- toExpr (HSE.IParen _ rule) = toExpr rule--instance ToStmts HSE.Decl where- toStmts (HSE.TypeDecl _ declHead ty) =- [ AST.STypeSynonym $- AST.TypeSynonym (tyDefToExpr $ declHeadToTyDef declHead) (toExpr ty)- ]- toStmts stmt@HSE.TypeFamDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.ClosedTypeFamDecl {} = [unsupportedStmt stmt]- toStmts (HSE.DataDecl _ dataOrNew _ declHead cases _) =- [ case dataOrNew of- HSE.NewType _ ->- AST.SNewtypeDeclaration $- AST.NewtypeDeclaration- (declHeadToTyDef declHead)- (toFunApp $ toExpr $ head cases)- HSE.DataType _ ->- AST.SDataDeclaration $- AST.DataDeclaration- (declHeadToTyDef declHead)- (map (toFunApp . toExpr) cases)- ]- toStmts stmt@HSE.GDataDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.DataFamDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.TypeInsDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.DataInsDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.GDataInsDecl {} = [unsupportedStmt stmt]- toStmts (HSE.ClassDecl _ ctxt declHead _ decls) =- [ AST.STypeclassDefinition $- AST.TypeclassDefinition- (tyDefToExpr $ declHeadToTyDef declHead)- (contextToExprs ctxt)- (maybe [] (map classDeclToTySig) decls)- ]- toStmts (HSE.InstDecl _ _ rule decls) =- [ AST.STypeclassInstance $- AST.TypeclassInstance- (toExpr rule)- (maybe [] (map instDeclToFunDef) decls)- ]- toStmts stmt@HSE.DerivDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.InfixDecl {} = [unsupportedStmt stmt]- toStmts (HSE.TypeSig _ names ty) =- map- (\name -> AST.STypeSignature $ AST.TypeSignature (toId name) (toExpr ty))- names- toStmts stmt@HSE.PatSynSig {} = [unsupportedStmt stmt]- toStmts (HSE.FunBind _ cases) = concatMap toStmts cases- toStmts (HSE.PatBind _ fn body whereBinds) =- [ AST.SFunctionDefinition $- AST.FunctionDefinition- (toId fn)- []- (toExpr body)- (bindsToFunDefs whereBinds)- ]- toStmts stmt@HSE.ForImp {} = [unsupportedStmt stmt]- toStmts stmt@HSE.ForExp {} = [unsupportedStmt stmt]- toStmts stmt@HSE.RulePragmaDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.DeprPragmaDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.WarnPragmaDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.InlineSig {} = [unsupportedStmt stmt]- toStmts stmt@HSE.InlineConlikeSig {} = [unsupportedStmt stmt]- toStmts stmt@HSE.SpecSig {} = [unsupportedStmt stmt]- toStmts stmt@HSE.SpecInlineSig {} = [unsupportedStmt stmt]- toStmts stmt@HSE.InstSig {} = [unsupportedStmt stmt]- toStmts stmt@HSE.AnnPragma {} = [unsupportedStmt stmt]- toStmts stmt@HSE.MinimalPragma {} = [unsupportedStmt stmt]- toStmts stmt@HSE.RoleAnnotDecl {} = [unsupportedStmt stmt]- toStmts stmt@HSE.CompletePragma {} = [unsupportedStmt stmt]--instDeclToFunDef :: HSE.InstDecl a -> AST.FunctionDefinition-instDeclToFunDef (HSE.InsDecl _ decl) =- case head $ toStmts decl of- AST.SFunctionDefinition funDef -> funDef-instDeclToFunDef HSE.InsType {} = error "Type families not supported!"-instDeclToFunDef HSE.InsData {} = error "Type families not supported!"-instDeclToFunDef HSE.InsGData {} = error "Type families not supported!"--classDeclToTySig :: HSE.ClassDecl a -> AST.TypeSignature-classDeclToTySig (HSE.ClsDecl _ decl) =- case toStmts decl of- [AST.STypeSignature tySig] -> tySig-classDeclToTySig HSE.ClsDataFam {} = error "Type families not supported!"-classDeclToTySig HSE.ClsTyFam {} = error "Type families not supported!"-classDeclToTySig HSE.ClsTyDef {} = error "Type families not supported!"-classDeclToTySig HSE.ClsDefSig {} = error "Default signatures not supported!"--instance ToExpr HSE.Asst where- toExpr (HSE.ClassA _ name tys) =- AST.EFunctionApplication $- AST.FunctionApplication (toExpr name) (map toExpr tys)- toExpr (HSE.WildCardA _ _) = AST.EIdentifier "_"--contextToExprs :: Maybe (HSE.Context a) -> [AST.Expression]-contextToExprs Nothing = []-contextToExprs (Just (HSE.CxSingle _ asst)) = [toExpr asst]-contextToExprs (Just (HSE.CxTuple _ assts)) = map toExpr assts-contextToExprs (Just (HSE.CxEmpty _)) = []--convertFile ::- (LastMember IO effs, Members '[ Effs.Console, Effs.FileSystem] effs)- => FilePath- -> FilePath- -> Eff effs String-convertFile path newPath = do- newContents <-- sendM (HSE.parseFile path) <&>- (\case- HSE.ParseOk parsedModule ->- unlines $ map (toAxel . denormalizeStatement) $ toStmts parsedModule- HSE.ParseFailed _ err -> error err)- putStrLn $ "Writing " <> newPath <> "..."- FS.writeFile newPath newContents- pure newPath
+ src/Axel/Haskell/Error.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell #-}++module Axel.Haskell.Error where++import Axel.Prelude++import Axel.Sourcemap+ ( ModuleInfo+ , Position(Position)+ , SourcePosition+ , renderSourcePosition+ )+import qualified Axel.Sourcemap as SM+import Axel.Utils.FilePath (replaceExtension)+import Axel.Utils.Json (_Int)+import Axel.Utils.Text (encodeUtf8Lazy, indent)++import Control.Lens.Operators ((^.), (^?))+import Control.Lens.TH (makeFieldsNoPrefix)+import Control.Lens.Tuple (_1, _2)+import Control.Monad (join)++import qualified Data.Aeson as Json+import Data.Aeson.Lens (_String, key)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import qualified Data.Text as T++data GhcError =+ GhcError+ { _message :: Text+ , _sourcePosition :: SourcePosition+ }+ deriving (Show)++makeFieldsNoPrefix ''GhcError++processErrors :: ModuleInfo -> Text -> Text+processErrors moduleInfo stackOutput =+ T.unlines $ concatMap (processStackOutputLine moduleInfo) $+ T.lines stackOutput++processStackOutputLine :: ModuleInfo -> Text -> [Text]+processStackOutputLine moduleInfo line =+ fromMaybe [line] (tryProcessGhcOutput moduleInfo line)++tryProcessGhcOutput :: ModuleInfo -> Text -> Maybe [Text]+tryProcessGhcOutput moduleInfo line = do+ let obj `viewText` field = obj ^? field . _String+ jsonLine <- Json.decode' @Json.Value (encodeUtf8Lazy line)+ msg <- jsonLine `viewText` key "doc"+ pure $ fromMaybe [msg] $ do+ jsonSpan <- jsonLine ^? key "span"+ startPosition <-+ Position <$> (jsonSpan ^? key "startLine" . _Int) <*>+ (jsonSpan ^? key "startCol" . _Int)+ filePath <- jsonSpan `viewText` key "file"+ let haskellSourcePosition = (T.unpack filePath, startPosition)+ let maybeAxelError =+ toAxelError moduleInfo $ GhcError msg haskellSourcePosition+ let haskellError =+ "\n" <> indent 4 msg <>+ "The above message is in terms of the generated Haskell, at " <>+ renderSourcePosition haskellSourcePosition <>+ ".\nIt couldn't be mapped to an Axel location (did a macro lose a sourcemapping annotation along the way?).\n"+ pure [fromMaybe haskellError maybeAxelError]++toAxelError :: ModuleInfo -> GhcError -> Maybe Text+toAxelError moduleInfo ghcError = do+ let haskellPath = ghcError ^. sourcePosition . _1+ let haskellPosition = ghcError ^. sourcePosition . _2+ let axelPath = replaceExtension (FilePath $ T.pack haskellPath) "axel"+ let positionHint startPos = "at " <> renderSourcePosition startPos+ SM.Output transpiledOutput <- M.lookup axelPath moduleInfo >>= snd+ axelSourcePosition <-+ join $ SM.findOriginalPosition transpiledOutput haskellPosition+ pure $ "\n" <> indent 4 (ghcError ^. message) <>+ "The above message is in terms of the generated Haskell, " <>+ positionHint (haskellPath, haskellPosition) <>+ ".\nTry checking " <>+ positionHint axelSourcePosition <>+ ".\nIf the Axel code at that position doesn't seem related, something may have gone wrong during a macro expansion.\n"
src/Axel/Haskell/File.hs view
@@ -1,160 +1,158 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} module Axel.Haskell.File where -import Prelude hiding (putStr, putStrLn)+import Axel.Prelude -import Axel.AST (Statement(SModuleDeclaration), ToHaskell(toHaskell))-import Axel.Eff.Console (putStr, putStrLn)+import Axel.AST+ ( SMStatement+ , Statement(SModuleDeclaration)+ , ToHaskell(toHaskell)+ , statementsToProgram+ )+import Axel.Eff.Console (putStrLn) import qualified Axel.Eff.Console as Effs (Console)+import Axel.Eff.Error (Error) import qualified Axel.Eff.FileSystem as Effs (FileSystem)-import qualified Axel.Eff.FileSystem as FS (readFile, removeFile, writeFile)+import qualified Axel.Eff.FileSystem as FS (readFile, writeFile) import qualified Axel.Eff.Ghci as Effs (Ghci)-import Axel.Eff.Process (StreamSpecification(InheritStreams))+import qualified Axel.Eff.Log as Effs (Log) import qualified Axel.Eff.Process as Effs (Process)-import Axel.Eff.Resource (readResource) import qualified Axel.Eff.Resource as Effs (Resource)-import qualified Axel.Eff.Resource as Res (astDefinition)-import Axel.Error (Error)-import Axel.Haskell.Converter (convertFile)-import Axel.Haskell.Prettify (prettifyHaskell)-import Axel.Haskell.Stack (interpretFile)-import Axel.Macros (ModuleInfo, exhaustivelyExpandMacros)-import Axel.Normalize (normalizeStatement)-import Axel.Parse- ( Expression(Symbol)- , parseSource- , programToTopLevelExpressions+import qualified Axel.Eff.Restartable as Effs (Restartable)+import Axel.Haskell.Convert (convertFile)+import Axel.Macros (handleFunctionApplication, processProgram)+import Axel.Normalize (normalizeStatement, withExprCtxt)+import Axel.Parse (parseMultiple, parseSource)+import Axel.Parse.AST (Expression(Symbol))+import Axel.Pretty (prettifyProgram)+import qualified Axel.Sourcemap as SM+ ( Expression+ , Output+ , raw+ , unwrapCompoundExpressions )-import Axel.Utils.Recursion (Recursive(bottomUpFmap))+import Axel.Sourcemap (ModuleInfo)+import Axel.Utils.FilePath (replaceExtension)+import Axel.Utils.Recursion (bottomUpFmap) -import Control.Lens.Operators ((%~), (<&>))+import Control.Lens (op)+import Control.Lens.Operators ((<&>), (?~)) import Control.Lens.Tuple (_2) import Control.Monad (forM, mapM, unless, void)-import Control.Monad.Freer (Eff, LastMember, Members)-import Control.Monad.Freer.Error (runError)-import qualified Control.Monad.Freer.Error as Effs (Error)-import Control.Monad.Freer.State (gets, modify)-import qualified Control.Monad.Freer.State as Effs (State) -import qualified Data.Map as Map (adjust, fromList, lookup)-import Data.Maybe (catMaybes, fromMaybe)+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 Data.Text as T (isSuffixOf, pack) -import System.FilePath (stripExtension, takeFileName)+import qualified Language.Haskell.Ghcid as Ghci (Ghci) -convertList :: Expression -> Expression+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+import qualified Polysemy.Reader as Sem+import qualified Polysemy.State as Sem++convertList :: (Data ann) => Expression ann -> Expression ann convertList = bottomUpFmap $ \case- Symbol "List" -> Symbol "[]"+ Symbol ann "List" -> Symbol ann "[]" x -> x -convertUnit :: Expression -> Expression+convertUnit :: (Data ann) => Expression ann -> Expression ann convertUnit = bottomUpFmap $ \case- Symbol "Unit" -> Symbol "()"- Symbol "unit" -> Symbol "()"+ Symbol ann "Unit" -> Symbol ann "()"+ Symbol ann "unit" -> Symbol ann "()" x -> x readModuleInfo ::- (Members '[ Effs.Error Error, Effs.FileSystem] effs)+ (Sem.Members '[ Sem.Error Error, Effs.FileSystem] effs) => [FilePath]- -> Eff effs ModuleInfo+ -> Sem.Sem effs ModuleInfo readModuleInfo axelFiles = do modules <- forM axelFiles $ \filePath -> do source <- FS.readFile filePath- exprs <- programToTopLevelExpressions <$> parseSource source+ exprs <-+ SM.unwrapCompoundExpressions <$> parseSource (Just filePath) source Alt moduleDecl <- mconcat . map Alt <$> mapM (\expr ->- runError @Error (normalizeStatement expr) <&> \case- Right (SModuleDeclaration moduleId) ->- Just (filePath, (moduleId, False))+ Sem.runError+ (Sem.runReader filePath $ withExprCtxt $ normalizeStatement expr) <&> \case+ Right (SModuleDeclaration _ moduleId) ->+ Just (filePath, (moduleId, Nothing)) _ -> Nothing) exprs pure moduleDecl- pure $ Map.fromList $ catMaybes modules+ pure $ M.fromList $ catMaybes modules transpileSource ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource, Effs.State ModuleInfo] effs)- => String- -> Eff effs String-transpileSource source =- prettifyHaskell . toHaskell <$>- (parseSource source >>=- exhaustivelyExpandMacros transpileFile' . convertList . convertUnit >>=- normalizeStatement)--convertExtension :: String -> String -> FilePath -> FilePath-convertExtension oldExt newExt axelPath =- let basePath =- if T.pack newExt `T.isSuffixOf` T.pack axelPath- then fromMaybe axelPath $ stripExtension newExt axelPath- else axelPath- in basePath <> oldExt--axelPathToHaskellPath :: FilePath -> FilePath-axelPathToHaskellPath = convertExtension ".hs" ".axel"--haskellPathToAxelPath :: FilePath -> FilePath-haskellPathToAxelPath = convertExtension ".axel" ".hs"+ 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+ )+ => FilePath+ -> Text+ -> Sem.Sem effs SM.Output+transpileSource filePath source =+ toHaskell . statementsToProgram <$>+ (parseSource (Just filePath) source >>=+ processProgram+ @fileExpanderEffs+ @funAppExpanderEffs+ handleFunctionApplication+ (void . transpileFileInPlace)+ filePath) --- | Convert a file in place.-convertFile' ::- (LastMember IO effs, Members '[ Effs.Console, Effs.FileSystem] effs)+convertFileInPlace ::+ (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error, Effs.FileSystem] effs) => FilePath- -> Eff effs FilePath-convertFile' path = do- let newPath = haskellPathToAxelPath path+ -> Sem.Sem effs FilePath+convertFileInPlace path = do+ let newPath = replaceExtension path "axel" void $ convertFile path newPath pure newPath transpileFile ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource, Effs.State ModuleInfo] effs)+ (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] effs) => FilePath -> FilePath- -> Eff effs ()+ -> Sem.Sem effs () transpileFile path newPath = do- putStr $ "Transpiling " <> path <> "..." fileContents <- FS.readFile path- newContents <- transpileSource fileContents- putStrLn $ " Transpiled to " <> newPath <> "!"- FS.writeFile newPath newContents- modify @ModuleInfo $ Map.adjust (_2 %~ not) 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 --- | Transpile a file in place.-transpileFile' ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource, Effs.State ModuleInfo] effs)+transpileFileInPlace ::+ (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource, Sem.Reader Ghci.Ghci, Sem.State ModuleInfo] effs) => FilePath- -> Eff effs FilePath-transpileFile' path = do- moduleInfo <- gets @ModuleInfo $ Map.lookup path+ -> Sem.Sem effs FilePath+transpileFileInPlace path = do+ moduleInfo <- Sem.gets $ M.lookup path let alreadyCompiled = case moduleInfo of- Just (_, isCompiled) -> isCompiled- Nothing -> False- let newPath = axelPathToHaskellPath path+ Just (_, Just _) -> True+ _ -> False+ let newPath = replaceExtension path "hs" unless alreadyCompiled $ transpileFile path newPath pure newPath -evalFile ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)+formatFileInPlace ::+ (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error] effs) => FilePath- -> Eff effs ()-evalFile path = do- putStrLn ("Building " <> takeFileName path <> "...")- let astDefinitionPath = "AutogeneratedAxelAST.hs"- readResource Res.astDefinition >>= FS.writeFile astDefinitionPath- let newPath = axelPathToHaskellPath path- putStrLn ("Running " <> takeFileName path <> "...")- void $ interpretFile @'InheritStreams newPath- FS.removeFile astDefinitionPath+ -> Sem.Sem effs ()+formatFileInPlace path = do+ contents <- FS.readFile path+ putStrLn $ "Formatting " <> op FilePath path <> "..."+ program <- parseMultiple (Just path) contents+ let prettifiedContents = prettifyProgram program+ FS.writeFile path prettifiedContents
src/Axel/Haskell/Language.hs view
@@ -1,43 +1,55 @@ module Axel.Haskell.Language where -import Data.Char (isSymbol)+import Axel.Prelude +import Data.Char (isSymbol, toUpper)+import qualified Data.Text as T+ -- https://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators-isOperator :: String -> Bool+isOperator :: Text -> Bool isOperator =- all $ \x -> isSymbol x || x `elem` map fst haskellOperatorSymbols || x == ','+ T.all $ \x ->+ isSymbol x || x `elem` map fst haskellOperatorSymbols || x == ',' -haskellOperatorSymbols :: [(Char, String)]+type SymbolReplacementMap = [(Char, Text)]++mkHygenicSymbolReplacementMap :: SymbolReplacementMap -> SymbolReplacementMap+mkHygenicSymbolReplacementMap =+ map (\(symbol, name) -> (symbol, "aXEL_SYMBOL_" <> T.map toUpper name <> "_"))++haskellOperatorSymbols :: SymbolReplacementMap haskellOperatorSymbols =- [ (':', "axelSymbolColon")- , ('!', "axelSymbolBang")- , ('#', "axelSymbolHash")- , ('$', "axelSymbolDollar")- , ('%', "axelSymbolPercent")- , ('&', "axelSymbolAmpersand")- , ('+', "axelSymbolPlus")- , ('*', "axelSymbolAsterisk")- , ('/', "axelSymbolSlash")- , ('<', "axelSymbolLess")- , ('>', "axelSymbolGreater")- , ('=', "axelSymbolEquals")- , ('\\', "axelSymbolBackslash")- , ('@', "axelSymbolAt")- , ('?', "axelSymbolQuestion")- , ('^', "axelSymbolCaret")- , ('-', "axelSymbolDash")- , ('|', "axelSymbolPipe")- , ('~', "axelSymbolTilde")- , ('.', "axelSymbolDot")- ]+ mkHygenicSymbolReplacementMap+ [ (':', "colon")+ , ('!', "bang")+ , ('#', "hash")+ , ('$', "dollar")+ , ('%', "percent")+ , ('&', "ampersand")+ , ('+', "plus")+ , ('*', "asterisk")+ , ('/', "slash")+ , ('<', "lessThan")+ , ('>', "greaterThan")+ , ('=', "equals")+ , ('\\', "backslash")+ , ('@', "at")+ , ('?', "questionMark")+ , ('^', "caret")+ , ('-', "hyphen")+ , ('|', "pipe")+ , ('~', "tilde")+ , ('.', "dot")+ ] -haskellSyntaxSymbols :: [(Char, String)]+haskellSyntaxSymbols :: SymbolReplacementMap haskellSyntaxSymbols =- [ (',', "axelSymbolComma")- , (';', "axelSymbolSemicolon")- , ('[', "axelSymbolLeftBracket")- , (']', "axelSymbolRightBracket")- , ('{', "axelSymbolLeftBrace")- , ('}', "axelSymbolRightBrace")- , ('`', "axelSymbolGrave")- ]+ mkHygenicSymbolReplacementMap+ [ (',', "comma")+ , (';', "semicolon")+ , ('[', "leftBracket")+ , (']', "rightBracket")+ , ('{', "rightBrace")+ , ('}', "leftBrace")+ , ('`', "tilde")+ ]
src/Axel/Haskell/Macros.hs view
@@ -1,29 +1,11 @@-{-# LANGUAGE OverloadedStrings #-} module Axel.Haskell.Macros where-import Axel- (applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION,- def_AXEL_AUTOGENERATED_MACRO_DEFINITION)-import Axel.Haskell.Language- (haskellOperatorSymbols, haskellSyntaxSymbols, isOperator)-import qualified Axel.Parse as Parse (syntaxSymbols)-import Data.List (foldl')+import qualified Prelude as GHCPrelude+import qualified Axel.Parse.AST as AST+import Axel.Prelude+import Axel.Haskell.Language(haskellOperatorSymbols,haskellSyntaxSymbols,isOperator)+import qualified Axel.Parse as Parse(syntaxSymbols)+import Data.List(foldl')+import Data.MonoTraversable(onotElem) import qualified Data.Text as T- (isSuffixOf, pack, replace, singleton, unpack)-hygenisizeMacroName oldName- = (let suffix- = if (isOperator oldName) then "%%%%%%%%%%" else- "_AXEL_AUTOGENERATED_MACRO_DEFINITION"- suffixedName- = if (T.isSuffixOf (T.pack suffix) (T.pack oldName)) then oldName- else ((<>) oldName suffix)- in- (T.unpack- (foldl'- (\ acc ((,) old new) ->- (T.replace (T.singleton old) (T.pack new) acc))- (T.pack suffixedName)- (filter (\ ((,) sym _) -> (notElem sym Parse.syntaxSymbols))- ((<>) haskellSyntaxSymbols haskellOperatorSymbols)))))- where--hygenisizeMacroName :: ((->) String String)+hygenisizeMacroName oldName = (let {suffix = if (isOperator oldName) then "%%%%%%%%%%" else "_AXEL_AUTOGENERATED_MACRO_DEFINITION";suffixedName = if (T.isSuffixOf suffix oldName) then oldName else ((<>) oldName suffix);symbolReplacementMap = if (isOperator oldName) then haskellSyntaxSymbols else ((<>) haskellSyntaxSymbols haskellOperatorSymbols)} in (foldl' (\acc ((,) old new) -> (T.replace (T.singleton old) new acc)) suffixedName (filter (\((,) sym _) -> (onotElem sym Parse.syntaxSymbols)) symbolReplacementMap)))+hygenisizeMacroName :: ((->) Text Text)
− src/Axel/Haskell/Prettify.hs
@@ -1,14 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Axel.Haskell.Prettify where--import Language.Haskell.Exts.Parser (ParseResult(ParseFailed, ParseOk), parse)-import Language.Haskell.Exts.Pretty (prettyPrint)-import Language.Haskell.Exts.SrcLoc (SrcSpanInfo)-import Language.Haskell.Exts.Syntax (Module)--prettifyHaskell :: String -> String-prettifyHaskell input =- case parse input of- ParseOk (ast :: Module SrcSpanInfo) -> prettyPrint ast- ParseFailed _ _ -> input
src/Axel/Haskell/Project.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Axel.Haskell.Project where +import Axel.Prelude+ import qualified Axel.Eff.Console as Effs (Console)+import Axel.Eff.Error (Error) import Axel.Eff.FileSystem ( copyFile , getCurrentDirectory@@ -13,11 +15,17 @@ ) import qualified Axel.Eff.FileSystem as Effs (FileSystem) import qualified Axel.Eff.Ghci as Effs (Ghci)+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.Resource (getResourcePath, newProjectTemplate) import qualified Axel.Eff.Resource as Effs (Resource)-import Axel.Error (Error)-import Axel.Haskell.File (readModuleInfo, transpileFile')+import Axel.Haskell.File+ ( convertFileInPlace+ , formatFileInPlace+ , readModuleInfo+ , transpileFileInPlace+ ) import Axel.Haskell.Stack ( addStackDependency , axelStackageId@@ -25,53 +33,92 @@ , createStackProject , runStackProject )+import Axel.Sourcemap (ModuleInfo)+import Axel.Utils.FilePath ((<.>), (</>))+import Axel.Utils.Monad (concatMapM) +import Control.Lens (op) import Control.Monad (void)-import Control.Monad.Freer (Eff, Members)-import qualified Control.Monad.Freer.Error as Effs (Error)-import Control.Monad.Freer.State (evalState) -import Data.Semigroup ((<>))-import qualified Data.Text as T (isSuffixOf, pack)+import qualified Data.Text as T -import System.FilePath ((</>))+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+import qualified Polysemy.State as Sem type ProjectPath = FilePath newProject ::- Members '[ Effs.FileSystem, Effs.Process, Effs.Resource] effs- => String- -> Eff effs ()+ Sem.Members '[ Effs.FileSystem, Effs.Process, Effs.Resource] effs+ => Text+ -> Sem.Sem effs () newProject projectName = do createStackProject projectName- addStackDependency axelStackageId projectName+ let projectPath = FilePath projectName+ addStackDependency axelStackageId projectPath templatePath <- getResourcePath newProjectTemplate let copyAxel filePath = do copyFile- (templatePath </> filePath <> ".axel")- (projectName </> filePath <> ".axel")- removeFile (projectName </> filePath <> ".hs")- mapM_ copyAxel ["Setup", "app" </> "Main", "src" </> "Lib", "test" </> "Spec"]+ (templatePath </> filePath <.> "axel")+ (projectPath </> filePath <.> "axel")+ removeFile (projectPath </> filePath <.> "hs")+ mapM_+ copyAxel+ [ FilePath "Setup"+ , FilePath "app" </> FilePath "Main"+ , FilePath "src" </> FilePath "Lib"+ , FilePath "test" </> FilePath "Spec"+ ] +data ProjectFileType+ = Axel+ | Backend++getProjectFiles ::+ (Sem.Member Effs.FileSystem effs)+ => ProjectFileType+ -> Sem.Sem effs [FilePath]+getProjectFiles fileType = do+ files <-+ concatMapM+ getDirectoryContentsRec+ [FilePath "app", FilePath "src", FilePath "test"]+ let ext =+ case fileType of+ Axel -> ".axel"+ Backend -> ".hs"+ pure $ filter (\filePath -> ext `T.isSuffixOf` op FilePath filePath) files+ transpileProject ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource] effs)- => Eff effs [FilePath]-transpileProject = do- files <- concat <$> mapM getDirectoryContentsRec ["app", "src", "test"]- let axelFiles =- filter (\filePath -> ".axel" `T.isSuffixOf` T.pack filePath) files- moduleInfo <- readModuleInfo axelFiles- evalState moduleInfo $ mapM transpileFile' axelFiles+ (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource] effs)+ => Sem.Sem effs ModuleInfo+transpileProject =+ Ghci.withGhci $ do+ axelFiles <- getProjectFiles Axel+ initialModuleInfo <- readModuleInfo axelFiles+ (moduleInfo, _) <-+ Sem.runState initialModuleInfo $ mapM transpileFileInPlace axelFiles+ pure moduleInfo buildProject ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource] effs)- => Eff effs ()+ (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Log, Effs.Process, Effs.Resource] effs)+ => Sem.Sem effs () buildProject = do projectPath <- getCurrentDirectory- void transpileProject- buildStackProject projectPath+ transpiledFiles <- transpileProject+ buildStackProject transpiledFiles projectPath +convertProject ::+ (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error, Effs.FileSystem, Effs.Process] effs)+ => Sem.Sem effs ()+convertProject = getProjectFiles Backend >>= void . traverse convertFileInPlace+ runProject ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process] effs)- => Eff effs ()+ (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Process] effs)+ => Sem.Sem effs () runProject = getCurrentDirectory >>= runStackProject++formatProject ::+ (Sem.Members '[ Effs.Console, Effs.FileSystem, Sem.Error Error] effs)+ => Sem.Sem effs ()+formatProject = getProjectFiles Axel >>= void . traverse formatFileInPlace
src/Axel/Haskell/Stack.hs view
@@ -1,172 +1,178 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-} module Axel.Haskell.Stack where -import Prelude hiding (putStrLn)+import Axel.Prelude import Axel.Eff.Console (putStrLn)-import qualified Axel.Eff.Console as Effs (Console)+import qualified Axel.Eff.Console as Effs+import Axel.Eff.Error (Error(ProjectError), fatal) import qualified Axel.Eff.FileSystem as FS- ( readFile- , withCurrentDirectory- , writeFile- )-import qualified Axel.Eff.FileSystem as Effs (FileSystem)+import qualified Axel.Eff.FileSystem as Effs import Axel.Eff.Process ( ProcessRunner , StreamSpecification(CreateStreams, InheritStreams)- , runProcess+ , execProcess )-import qualified Axel.Eff.Process as Effs (Process)-import Axel.Error (Error(ProjectError), fatal)+import qualified Axel.Eff.Process as Effs+import Axel.Haskell.Error (processErrors)+import Axel.Parse (Parser)+import Axel.Sourcemap (ModuleInfo)+import Axel.Utils.FilePath (takeFileName) +import Control.Lens (op) import Control.Lens.Operators ((%~)) import Control.Monad (void)-import Control.Monad.Freer (Eff, Member, Members)-import Control.Monad.Freer.Error (throwError)-import qualified Control.Monad.Freer.Error as Effs (Error) import Data.Aeson.Lens (_Array, key)-import qualified Data.ByteString.Char8 as B (pack, unpack) import Data.Function ((&)) import Data.List (foldl')-import qualified Data.Text as T (pack)+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 (Value(String), decodeEither', encode)+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 System.FilePath (takeFileName) -import Text.Regex.PCRE ((=~), getAllTextSubmatches)+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P type ProjectPath = FilePath -type StackageId = String+type StackageId = Text -type StackageResolver = String+type StackageResolver = Text -type Target = String+type Target = Text -type Version = String+type Version = Text stackageResolverWithAxel :: StackageResolver stackageResolverWithAxel = "nightly" axelStackageVersion :: Version-axelStackageVersion = showVersion version+axelStackageVersion = T.pack $ showVersion version axelStackageId :: StackageId axelStackageId = "axel" getStackProjectTargets ::- (Members '[ Effs.FileSystem, Effs.Process] effs)+ (Sem.Members '[ Effs.FileSystem, Effs.Process] effs) => ProjectPath- -> Eff effs [Target]+ -> Sem.Sem effs [Target] getStackProjectTargets projectPath = FS.withCurrentDirectory projectPath $ do- (_, _, stderr) <- runProcess @'CreateStreams "stack" ["ide", "targets"] ""- pure $ lines stderr+ (_, _, stderr) <- execProcess @'CreateStreams "stack ide targets" ""+ pure $ T.lines stderr addStackDependency ::- (Member Effs.FileSystem effs) => StackageId -> ProjectPath -> Eff effs ()+ (Sem.Member Effs.FileSystem effs)+ => StackageId+ -> ProjectPath+ -> Sem.Sem effs () addStackDependency dependencyId projectPath = FS.withCurrentDirectory projectPath $ do- let packageConfigPath = "package.yaml"+ let packageConfigPath = FilePath "package.yaml" packageConfigContents <- FS.readFile packageConfigPath- case Yaml.decodeEither' $ B.pack packageConfigContents of+ case Yaml.decodeEither' $ T.encodeUtf8 packageConfigContents of Right contents -> let newContents :: Yaml.Value = contents & key "dependencies" . _Array %~- cons (Yaml.String $ T.pack dependencyId)- encodedContents = B.unpack $ Yaml.encode newContents+ cons (Yaml.String dependencyId)+ encodedContents = T.decodeUtf8 $ Yaml.encode newContents in FS.writeFile packageConfigPath encodedContents Left _ -> fatal "addStackDependency" "0001" buildStackProject ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process] effs)- => ProjectPath- -> Eff effs ()-buildStackProject projectPath = do- putStrLn ("Building " <> takeFileName projectPath <> "...")+ (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Process] effs)+ => ModuleInfo+ -> ProjectPath+ -> Sem.Sem effs ()+buildStackProject moduleInfo projectPath = do+ putStrLn ("Building " <> op FilePath (takeFileName projectPath) <> "...") result <- FS.withCurrentDirectory projectPath $- runProcess @'CreateStreams "stack" ["build"] ""+ execProcess @'CreateStreams "stack build --ghc-options='-ddump-json'" "" case result of (ExitSuccess, _, _) -> pure ()- (ExitFailure _, stdout, stderr) ->- throwError $+ (ExitFailure _, _, stderr) ->+ Sem.throw $ ProjectError- ("Project failed to build.\n\nStdout:\n" <> stdout <> "\n\nStderr:\n" <>- stderr)+ ("Project failed to build.\n\n" <> processErrors moduleInfo stderr) createStackProject ::- (Members '[ Effs.FileSystem, Effs.Process] effs) => String -> Eff effs ()+ (Sem.Members '[ Effs.FileSystem, Effs.Process] effs)+ => Text+ -> Sem.Sem effs () createStackProject projectName = do void $- runProcess @'CreateStreams "stack" ["new", projectName, "new-template"] ""- setStackageResolver projectName stackageResolverWithAxel+ execProcess+ @'CreateStreams+ ("stack new " <> projectName <> " new-template")+ ""+ setStackageResolver (FilePath projectName) stackageResolverWithAxel runStackProject ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process] effs)+ (Sem.Members '[ Effs.Console, Sem.Error Error, Effs.FileSystem, Effs.Process] effs) => ProjectPath- -> Eff effs ()+ -> Sem.Sem effs () runStackProject projectPath = do targets <- getStackProjectTargets projectPath case findExeTargets targets of [target] -> do- putStrLn ("Running " <> target <> "...")- void $ runProcess @'InheritStreams "stack" ["exec", target]+ putStrLn $ "Running " <> target <> "..."+ void $ execProcess @'InheritStreams ("stack exec " <> target) _ ->- throwError $ ProjectError "No executable target was unambiguously found!"+ 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 getAllTextSubmatches $ target =~- ("([^:]*):exe:([^:]*)" :: String) of- [_fullMatch, _projectName, targetName] -> targetName : acc- _ -> acc)+ case P.parseMaybe exeTarget target of+ Just targetName -> targetName : acc+ Nothing -> acc) [] setStackageResolver ::- (Members '[ Effs.FileSystem, Effs.Process] effs)+ (Sem.Members '[ Effs.FileSystem, Effs.Process] effs) => ProjectPath -> StackageResolver- -> Eff effs ()+ -> Sem.Sem effs () setStackageResolver projectPath resolver = void $ FS.withCurrentDirectory projectPath $- runProcess @'CreateStreams "stack" ["config", "set", "resolver", resolver] ""+ execProcess @'CreateStreams ("stack config set resolver " <> resolver) "" -includeAxelArguments :: [String]+includeAxelArguments :: Text includeAxelArguments =- ["--resolver", stackageResolverWithAxel, "--package", axelStackageId]+ T.unwords+ ["--resolver", stackageResolverWithAxel, "--package", axelStackageId] compileFile ::- forall (streamSpec :: StreamSpecification) effs. (Member Effs.Process effs)+ forall (streamSpec :: StreamSpecification) effs.+ (Sem.Member Effs.Process effs) => FilePath- -> ProcessRunner streamSpec (Eff effs)-compileFile filePath =- let args = concat [["ghc"], includeAxelArguments, ["--", filePath]]- in runProcess @streamSpec @effs "stack" args+ -> ProcessRunner streamSpec (Sem.Sem effs)+compileFile (FilePath filePath) =+ let cmd = T.unwords ["stack", "ghc", includeAxelArguments, "--", filePath]+ in execProcess @streamSpec @effs cmd interpretFile ::- forall (streamSpec :: StreamSpecification) effs. (Member Effs.Process effs)+ forall (streamSpec :: StreamSpecification) effs.+ (Sem.Member Effs.Process effs) => FilePath- -> ProcessRunner streamSpec (Eff effs)-interpretFile filePath =- let args = concat [["runghc"], includeAxelArguments, ["--", filePath]]- in runProcess @streamSpec @effs "stack" args+ -> ProcessRunner streamSpec (Sem.Sem effs)+interpretFile (FilePath filePath) =+ let cmd = T.unwords ["stack", "runghc", includeAxelArguments, "--", filePath]+ in execProcess @streamSpec @effs cmd
src/Axel/Macros.hs view
@@ -1,323 +1,611 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-} module Axel.Macros where -import Prelude hiding (putStrLn)+import Axel.Prelude +import Axel (isPrelude, preludeMacros) import Axel.AST- ( Expression(EFunctionApplication, EIdentifier)+ ( Expression(EFunctionApplication, EIdentifier, ERawExpression) , FunctionApplication(FunctionApplication)+ , FunctionDefinition(FunctionDefinition) , Identifier+ , ImportSpecification(ImportAll) , MacroDefinition- , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,- SMacroImport, SModuleDeclaration, SNewtypeDeclaration, SPragma,- SQualifiedImport, SRawStatement, SRestrictedImport, STopLevel,- STypeSignature, STypeSynonym, STypeclassDefinition,- STypeclassInstance, SUnrestrictedImport)+ , MacroImport(MacroImport)+ , QualifiedImport(QualifiedImport)+ , SMStatement+ , Statement(SFunctionDefinition, SMacroDefinition, SMacroImport,+ SMacroImport, SModuleDeclaration, SQualifiedImport,+ SQualifiedImport, SRawStatement, SRestrictedImport, STypeSignature) , ToHaskell(toHaskell) , TypeSignature(TypeSignature)+ , _SMacroDefinition+ , _SModuleDeclaration , functionDefinition , imports , moduleName , name+ , statementsToProgram ) import Axel.Denormalize (denormalizeStatement)+import qualified Axel.Eff as Effs+import Axel.Eff.Error (Error(MacroError), fatal) import qualified Axel.Eff.FileSystem as Effs (FileSystem)-import qualified Axel.Eff.FileSystem as FS (removeFile, writeFile)+import qualified Axel.Eff.FileSystem as FS import qualified Axel.Eff.Ghci as Effs (Ghci)-import qualified Axel.Eff.Ghci as Ghci (exec, start, stop)+import qualified Axel.Eff.Ghci as Ghci+import qualified Axel.Eff.Log as Effs (Log)+import Axel.Eff.Log (logStrLn) import qualified Axel.Eff.Process as Effs (Process)-import Axel.Eff.Resource (readResource)-import qualified Axel.Eff.Resource as Effs (Resource)-import qualified Axel.Eff.Resource as Res- ( astDefinition- , macroDefinitionAndEnvironmentFooter- , macroDefinitionAndEnvironmentHeader- , macroScaffold- )-import Axel.Error (Error)+import qualified Axel.Eff.Restartable as Effs (Restartable)+import Axel.Eff.Restartable (restart, runRestartable)+import Axel.Haskell.Error (processErrors) import Axel.Haskell.Macros (hygenisizeMacroName)-import Axel.Haskell.Prettify (prettifyHaskell)-import Axel.Normalize (normalizeStatement)-import qualified Axel.Parse as Parse- ( Expression(SExpression, Symbol)- , parseMultiple- , programToTopLevelExpressions- , topLevelExpressionsToProgram+import Axel.Normalize+ ( normalizeExpression+ , normalizeStatement+ , unsafeNormalize+ , unsafeNormalize+ , withExprCtxt )-import Axel.Utils.Display (Delimiter(Newlines), delimit)-import Axel.Utils.Function (uncurry3)-import Axel.Utils.Recursion (Recursive(bottomUpTraverse), exhaustM)-import Axel.Utils.String (replace)+import Axel.Parse (parseMultiple)+import Axel.Parse.AST (_SExpression, bottomUpFmapSplicing, toAxel)+import qualified Axel.Parse.AST as Parse+import Axel.Sourcemap+ ( ModuleInfo+ , SourceMetadata+ , isCompoundExpressionWrapperHead+ , quoteSMExpression+ , renderSourcePosition+ , unwrapCompoundExpressions+ , wrapCompoundExpressions+ )+import qualified Axel.Sourcemap as SM+import Axel.Utils.FilePath ((<.>), (</>), replaceExtension, takeFileName)+import Axel.Utils.List (filterMap, filterMapOut, head')+import Axel.Utils.Maybe (whenMaybe)+import Axel.Utils.Recursion (bottomUpFmap, zipperTopDownTraverse)+import Axel.Utils.Zipper (unsafeLeft, unsafeUp) -import Control.Lens.Cons (snoc)-import Control.Lens.Operators ((%~), (^.))-import Control.Lens.Tuple (_1, _2)-import Control.Monad (foldM, unless, void)-import Control.Monad.Freer (Eff, Members)-import qualified Control.Monad.Freer.Error as Effs (Error)-import Control.Monad.Freer.State (gets)-import qualified Control.Monad.Freer.State as Effs (State)+import Control.Lens (_1, op, snoc)+import Control.Lens.Extras (is)+import Control.Lens.Operators ((%~), (^.), (^?))+import Control.Monad (guard, unless, when) -import Data.Function ((&))-import Data.List (nub)-import Data.Map (Map)-import qualified Data.Map as Map (filter, toList)-import Data.Maybe (listToMaybe, mapMaybe)+import Data.Function (on)+import Data.Generics.Uniplate.Zipper (Zipper, fromZipper, hole, replaceHole, up)+import Data.Hashable (hash)+import Data.List (intersperse, nub)+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 Ghci (Ghci)+import qualified Language.Haskell.Ghcid as Ghcid -import System.FilePath ((<.>))+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+import qualified Polysemy.Reader as Sem+import qualified Polysemy.State as Sem -type ModuleInfo = Map Identifier (FilePath, Bool)+type FunctionApplicationExpanderArgs a = SM.Expression -> a -hygenisizeMacroDefinition :: MacroDefinition -> MacroDefinition-hygenisizeMacroDefinition macroDef =- macroDef & functionDefinition . name %~ hygenisizeMacroName+type FunctionApplicationExpander effs+ = Effs.Callback effs FunctionApplicationExpanderArgs (Maybe [SM.Expression]) -generateMacroProgram ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Resource] effs)+type FileExpanderArgs a = FilePath -> a++type FileExpander effs = Effs.Callback effs FileExpanderArgs ()++-- | 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+ )+ => FunctionApplicationExpander funAppExpanderEffs+ -> FileExpander fileExpanderEffs+ -> FilePath+ -> SM.Expression+ -> Sem.Sem effs [SMStatement]+processProgram expandFunApp expandFile filePath program = do+ newProgramExpr <-+ Sem.runReader filePath $+ expandProgramExpr+ @funAppExpanderEffs+ @fileExpanderEffs+ expandFunApp+ expandFile+ program+ newStmts <-+ mapM+ (Sem.runReader filePath . withExprCtxt . normalizeStatement)+ (unwrapCompoundExpressions newProgramExpr)+ let addAstImport =+ insertImports+ [ SQualifiedImport $+ QualifiedImport Nothing "Prelude" "GHCPrelude" (ImportAll Nothing)+ , SQualifiedImport $+ QualifiedImport Nothing "Axel.Parse.AST" "AST" (ImportAll Nothing)+ ]+ pure $ finalizeProgram $ addAstImport newStmts++finalizeProgram :: [SMStatement] -> [SMStatement]+finalizeProgram stmts =+ let expandQuotes =+ bottomUpFmapSplicing+ (\case+ Parse.SExpression _ (Parse.Symbol _ "quote":xs) ->+ map quoteSMExpression xs+ x -> [x])+ convertList =+ bottomUpFmap $ \case+ Parse.Symbol ann' "List" -> Parse.Symbol ann' "[]"+ x -> x+ convertUnit =+ bottomUpFmap $ \case+ Parse.Symbol ann' "Unit" -> Parse.Symbol ann' "()"+ Parse.Symbol ann' "unit" -> Parse.Symbol ann' "()"+ x -> x+ (nonMacroDefs, macroDefs) = filterMapOut (^? _SMacroDefinition) stmts+ hygenicMacroDefs = map hygenisizeMacroDefinition macroDefs+ macroTySigs = typeMacroDefinitions hygenicMacroDefs+ toTopLevelStmts =+ map (unsafeNormalize normalizeStatement) . unwrapCompoundExpressions+ toProgramExpr = wrapCompoundExpressions . map denormalizeStatement+ in toTopLevelStmts $ convertUnit $ convertList $ expandQuotes $ toProgramExpr $+ nonMacroDefs <>+ map SMacroDefinition hygenicMacroDefs <>+ macroTySigs++isMacroImported ::+ (Sem.Member (Sem.State [SMStatement]) effs) => Identifier- -> [MacroDefinition]- -> [Statement]- -> [Parse.Expression]- -> Eff effs (String, String, String)-generateMacroProgram oldMacroName macroDefs env args = do- astDef <- readResource Res.astDefinition- scaffold <- insertArgs <$> readResource Res.macroScaffold- macroDefAndEnv <-- do header <- readResource Res.macroDefinitionAndEnvironmentHeader- footer <-- insertDefName <$> readResource Res.macroDefinitionAndEnvironmentFooter- pure $ unlines [header, macroDefAndEnvBody, footer]- pure (astDef, scaffold, macroDefAndEnv)- where- insertDefName =- let defNamePlaceholder = "%%%MACRO_NAME%%%"- in replace defNamePlaceholder newMacroName- insertArgs =- let argsPlaceholder = "%%%ARGUMENTS%%%"- in replace argsPlaceholder (show args)- newMacroName = hygenisizeMacroName oldMacroName- macroDefAndEnvBody =- let hygenicMacroDefs = map hygenisizeMacroDefinition macroDefs- in prettifyHaskell $ delimit Newlines $- map toHaskell (env <> map SMacroDefinition hygenicMacroDefs)+ -> Sem.Sem effs Bool+isMacroImported macroName = do+ let isFromPrelude = macroName `elem` preludeMacros+ isImportedDirectly <-+ any+ (\case+ SMacroImport macroImport -> macroName `elem` macroImport ^. imports+ _ -> False) <$>+ Sem.get+ pure $ isFromPrelude || isImportedDirectly -expansionPass ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource, Effs.State ModuleInfo] effs)- => Ghci.Ghci- -> (FilePath -> Eff effs a)- -> Parse.Expression- -> Eff effs Parse.Expression-expansionPass ghci expandFile programExpr =- Parse.topLevelExpressionsToProgram . map denormalizeStatement <$>- expandMacros ghci expandFile (Parse.programToTopLevelExpressions programExpr)+ensureCompiledDependency ::+ forall fileExpanderEffs effs.+ (Sem.Member (Sem.State ModuleInfo) effs, Sem.Members fileExpanderEffs effs)+ => FileExpander fileExpanderEffs+ -> Identifier+ -> Sem.Sem effs ()+ensureCompiledDependency expandFile dependencyName = do+ moduleInfo <-+ Sem.gets (M.filter (\(moduleId', _) -> moduleId' == dependencyName))+ case head' $ M.toList moduleInfo of+ Just (dependencyFilePath, (_, transpiledOutput)) ->+ when (isNothing transpiledOutput) $ expandFile dependencyFilePath+ Nothing -> pure () -exhaustivelyExpandMacros ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource, Effs.State ModuleInfo] effs)- => (FilePath -> Eff effs a)- -> Parse.Expression- -> Eff effs Parse.Expression-exhaustivelyExpandMacros expandFile program = do- ghci <- Ghci.start- expandedTopLevelExprs <-- Parse.programToTopLevelExpressions <$>- exhaustM (expansionPass ghci expandFile) program- macroTypeSigs <-- do normalizedStmts <- traverse normalizeStatement expandedTopLevelExprs- let typeSigs =- typeMacroDefinitions $ mapMaybe isMacroDefinition normalizedStmts- pure $ map (denormalizeStatement . STypeSignature) typeSigs- Ghci.stop ghci- pure $- Parse.topLevelExpressionsToProgram (expandedTopLevelExprs <> macroTypeSigs)- where- isMacroDefinition (SMacroDefinition x) = Just x- isMacroDefinition _ = Nothing+isStatementFocused :: Zipper SM.Expression SM.Expression -> Bool+isStatementFocused zipper =+ let wholeProgramExpr = fromZipper zipper+ isCompoundExpr = Just wholeProgramExpr == (hole <$> up zipper)+ isCompoundExprWrapper =+ case hole zipper of+ Parse.Symbol _ "begin" -> True+ _ -> False+ in isCompoundExpr && not isCompoundExprWrapper -isStatementNonconflicting :: Statement -> Bool-isStatementNonconflicting (SDataDeclaration _) = True-isStatementNonconflicting (SFunctionDefinition _) = True-isStatementNonconflicting (SPragma _) = True-isStatementNonconflicting (SMacroDefinition _) = True-isStatementNonconflicting (SMacroImport _) = True-isStatementNonconflicting (SModuleDeclaration _) = False-isStatementNonconflicting (SNewtypeDeclaration _) = True-isStatementNonconflicting (SQualifiedImport _) = True-isStatementNonconflicting (SRawStatement _) = True-isStatementNonconflicting (SRestrictedImport _) = True-isStatementNonconflicting (STopLevel _) = False-isStatementNonconflicting (STypeclassDefinition _) = True-isStatementNonconflicting (STypeclassInstance _) = True-isStatementNonconflicting (STypeSignature _) = True-isStatementNonconflicting (STypeSynonym _) = True-isStatementNonconflicting (SUnrestrictedImport _) = True+-- | 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.+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+ )+ => FunctionApplicationExpander funAppExpanderEffs+ -> FileExpander fileExpanderEffs+ -> SM.Expression+ -> Sem.Sem effs SM.Expression+expandProgramExpr expandFunApp expandFile programExpr =+ runRestartable @SM.Expression programExpr $+ Sem.evalState ([] :: [SMStatement]) .+ zipperTopDownTraverse+ (\zipper -> do+ when (isStatementFocused zipper) $+ -- NOTE This algorithm will exclude the last statement, but we won't+ -- have any macros that rely on it (since macros can only access+ -- what is before them in the file). Thus, this omission is okay.+ let prevTopLevelExpr = hole $ unsafeLeft zipper+ in unless (isCompoundExpressionWrapperHead prevTopLevelExpr) $+ addStatementToMacroEnvironment+ @fileExpanderEffs+ expandFile+ prevTopLevelExpr+ let expr = hole zipper+ when (is _SExpression expr) $ do+ maybeNewExprs <- expandFunApp expr+ case maybeNewExprs of+ Just newExprs -> replaceExpr zipper newExprs >>= restart+ Nothing -> pure ()+ pure expr) -isMacroImported :: Identifier -> [Statement] -> Bool-isMacroImported macroName =- any- (\case- SMacroImport macroImport -> macroName `elem` macroImport ^. imports- _ -> False)+-- | Returns the full program expr (after the necessary substitution has been applied).+replaceExpr ::+ (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath] effs)+ => Zipper SM.Expression SM.Expression+ -> [SM.Expression]+ -> Sem.Sem effs SM.Expression+replaceExpr zipper newExprs =+ let programExpr = fromZipper zipper+ oldExpr = hole zipper+ -- NOTE Using `unsafeUp` is safe since `begin` cannot be the name of a macro,+ -- and thus `zipper` will never be focused on the whole program.+ oldParentExprZ = unsafeUp zipper+ newParentExpr =+ case hole oldParentExprZ of+ Parse.SExpression ann' xs ->+ let xs' = do+ x <- xs+ -- TODO What if there are multiple, equivalent copies of `oldExpr`?+ -- If they are not top-level statements, then the macro in question+ -- must already exist and thus we would have expanded it already.+ -- If they are top-level statements, but e.g. were auto-generated, then+ -- `==` will call them equal. If the macro in question did not exist+ -- when the first statement was defined, but it does by the second+ -- statement, then our result may be incorrect.+ if x == oldExpr+ then newExprs+ else pure x+ in Parse.SExpression ann' xs'+ _ -> fatal "expandProgramExpr" "0001"+ newProgramExpr = fromZipper $ replaceHole newParentExpr oldParentExprZ+ in if newProgramExpr == programExpr+ then throwLoopError oldExpr newExprs+ else pure newProgramExpr -typeMacroDefinitions :: [MacroDefinition] -> [TypeSignature]-typeMacroDefinitions macroDefs =- map- (flip- TypeSignature- (EFunctionApplication $- FunctionApplication- (EIdentifier "->")- [ EFunctionApplication $- FunctionApplication- (EIdentifier "[]")- [EIdentifier "AST.Expression"]- , EFunctionApplication $- FunctionApplication- (EIdentifier "IO")- [ EFunctionApplication $- FunctionApplication- (EIdentifier "[]")- [EIdentifier "AST.Expression"]+throwLoopError ::+ (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath] effs)+ => SM.Expression+ -> [SM.Expression]+ -> Sem.Sem effs a+throwLoopError oldExpr newExprs = do+ filePath <- Sem.ask+ Sem.throw $+ MacroError+ filePath+ oldExpr+ ("Infinite loop detected during macro expansion!\nCheck that no macro calls expand (directly or indirectly) to themselves.\n" <>+ toAxel oldExpr <>+ " expanded into " <>+ T.unwords (map toAxel newExprs) <>+ ".")++addStatementToMacroEnvironment ::+ forall fileExpanderEffs effs.+ ( Sem.Members '[ Sem.Error Error, Sem.State ModuleInfo, Sem.Reader FilePath, Sem.State [SMStatement]] effs+ , Sem.Members fileExpanderEffs effs+ )+ => FileExpander fileExpanderEffs+ -> SM.Expression+ -> Sem.Sem effs ()+addStatementToMacroEnvironment expandFile newExpr = do+ filePath <- Sem.ask+ stmt <- Sem.runReader filePath $ withExprCtxt $ normalizeStatement newExpr+ let maybeDependencyName =+ case stmt of+ SRestrictedImport restrictedImport ->+ Just $ restrictedImport ^. moduleName+ SQualifiedImport qualifiedImport ->+ Just $ qualifiedImport ^. moduleName+ SMacroImport macroImport -> Just $ macroImport ^. moduleName+ _ -> Nothing+ whenMaybe maybeDependencyName $+ ensureCompiledDependency @fileExpanderEffs expandFile+ Sem.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)+ => SM.Expression+ -> Sem.Sem effs (Maybe [SM.Expression])+handleFunctionApplication fnApp@(Parse.SExpression ann (Parse.Symbol _ functionName:args)) = do+ shouldExpand <- isMacroCall $ T.pack functionName+ if shouldExpand+ then Just <$>+ withExpansionId+ fnApp+ (expandMacroApplication ann (T.pack functionName) args)+ else pure Nothing+handleFunctionApplication _ = pure Nothing++isMacroCall ::+ (Sem.Member (Sem.State [SMStatement]) effs)+ => Identifier+ -> Sem.Sem effs Bool+isMacroCall function = do+ localDefs <- lookupMacroDefinitions function+ let isDefinedLocally = not $ null localDefs+ isImported <- isMacroImported function+ pure $ isImported || isDefinedLocally++lookupMacroDefinitions ::+ (Sem.Member (Sem.State [SMStatement]) effs)+ => Identifier+ -> Sem.Sem effs [MacroDefinition (Maybe SM.Expression)]+lookupMacroDefinitions identifier =+ filterMap+ (\stmt -> do+ macroDef <- stmt ^? _SMacroDefinition+ guard $ identifier == (macroDef ^. functionDefinition . name)+ pure macroDef) <$>+ Sem.get++hygenisizeMacroDefinition :: MacroDefinition ann -> MacroDefinition ann+hygenisizeMacroDefinition = functionDefinition . name %~ hygenisizeMacroName++insertImports :: [SMStatement] -> [SMStatement] -> [SMStatement]+insertImports newStmts program =+ case split (whenElt $ is _SModuleDeclaration) program of+ [preEnv, moduleDeclaration, postEnv] ->+ preEnv <> moduleDeclaration <> newStmts <> postEnv+ [_] -> newStmts <> program+ _ -> fatal "insertImports" "0001" -- TODO Replace with error message indicating that only one module declaration is allowed!++mkMacroTypeSignature :: Identifier -> SMStatement+mkMacroTypeSignature =+ SRawStatement Nothing .+ (<> " :: [AST.Expression SM.SourceMetadata] -> IO [AST.Expression SM.SourceMetadata]")++newtype ExpansionId =+ ExpansionId Text++mkMacroDefAndEnvModuleName :: ExpansionId -> Identifier+mkMacroDefAndEnvModuleName (ExpansionId expansionId) =+ "AutogeneratedAxelMacroDefinitionAndEnvironment" <> expansionId++mkScaffoldModuleName :: ExpansionId -> Identifier+mkScaffoldModuleName (ExpansionId expansionId) =+ "AutogeneratedAxelScaffold" <> expansionId++generateMacroProgram ::+ (Sem.Members '[ Sem.Error Error, Effs.FileSystem, Sem.Reader ExpansionId, Sem.State [SMStatement]] effs)+ => FilePath+ -> Identifier+ -> [SM.Expression]+ -> Sem.Sem effs (SM.Output, SM.Output)+generateMacroProgram filePath' oldMacroName args = do+ macroDefAndEnvModuleName <- Sem.asks mkMacroDefAndEnvModuleName+ scaffoldModuleName <- Sem.asks mkScaffoldModuleName+ let newMacroName = hygenisizeMacroName oldMacroName+ let mainFnName = "main_AXEL_AUTOGENERATED_FUNCTION_DEFINITION"+ let footer =+ [ mkMacroTypeSignature mainFnName+ , SRawStatement Nothing $ mainFnName <> " = " <> newMacroName+ ]+ let (header, scaffold) =+ let mkModuleDecl = SModuleDeclaration Nothing+ mkQualImport moduleName' alias =+ SQualifiedImport $+ QualifiedImport Nothing moduleName' alias (ImportAll Nothing)+ mkMacroImport moduleName' macros =+ SMacroImport $ MacroImport Nothing moduleName' macros+ mkId = EIdentifier Nothing+ mkQualId moduleName' identifier =+ EIdentifier Nothing $ moduleName' <> "." <> identifier+ mkTySig fnName ty = STypeSignature $ TypeSignature Nothing fnName ty+ mkFnDef fnName args' body =+ SFunctionDefinition $+ FunctionDefinition Nothing fnName args' body []+ mkFnApp fn args' =+ EFunctionApplication $ FunctionApplication Nothing fn args'+ mkRawExpr = ERawExpression Nothing+ mkList xs =+ mkFnApp (mkId "[") $ intersperse (mkRawExpr ",") xs <> [mkId "]"] -- This is VERY hacky, but it'll work without too much effort for now.+ in ( [mkMacroImport "Axel" preludeMacros | not $ isPrelude filePath'] <> -- We can't import the Axel prelude if we're actually compiling it.+ [ mkQualImport "Prelude" "GHCPrelude" -- (in case `-XNoImplicitPrelude` is enabled)+ , mkQualImport "Axel.Parse.AST" "AST"+ , mkQualImport "Axel.Sourcemap" "SM" ]- ]))- macroNames+ , [ mkModuleDecl scaffoldModuleName+ , mkQualImport "Prelude" "GHCPrelude" -- (in case `-XNoImplicitPrelude` is enabled)+ , mkQualImport macroDefAndEnvModuleName macroDefAndEnvModuleName+ , mkQualImport "Axel.Parse.AST" "AST"+ , mkQualImport "Axel.Sourcemap" "SM"+ , mkTySig "main" $ mkFnApp (mkId "GHCPrelude.IO") [mkId "()"]+ , mkFnDef "main" [] $+ mkFnApp+ (mkId "(GHCPrelude.>>=)")+ [ mkFnApp+ (mkQualId+ macroDefAndEnvModuleName+ "main_AXEL_AUTOGENERATED_FUNCTION_DEFINITION")+ [ mkList+ (map+ (unsafeNormalize normalizeExpression .+ quoteSMExpression)+ args)+ ]+ , mkFnApp+ (mkId "(GHCPrelude..)")+ [ mkId "GHCPrelude.putStrLn"+ , mkFnApp+ (mkId "(GHCPrelude..)")+ [ mkId "GHCPrelude.unlines"+ , mkFnApp (mkId "GHCPrelude.map") [mkId "AST.toAxel'"]+ ]+ ]+ ]+ ])+ auxEnv <- Sem.get @[SMStatement]+ -- TODO If the file being transpiled has pragmas but no explicit module declaration,+ -- they will be erroneously included *after* the module declaration.+ -- Should we just require Axel files to have module declarations, or is there a+ -- less intrusive alternate solution?+ let macroDefAndEnv =+ let moduleDecl = SModuleDeclaration Nothing macroDefAndEnvModuleName+ programStmts =+ replaceModuleDecl moduleDecl $ insertImports header $ auxEnv <>+ footer+ in finalizeProgram programStmts+ pure $+ uncurry+ ((,) `on` toHaskell . statementsToProgram)+ (scaffold, macroDefAndEnv) where- macroNames = nub $ map (^. functionDefinition . name) macroDefs+ replaceModuleDecl newModuleDecl stmts =+ if any (is _SModuleDeclaration) stmts+ then map+ (\case+ SModuleDeclaration _ _ -> newModuleDecl+ x -> x)+ stmts+ else newModuleDecl : stmts -expandMacros ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource, Effs.State ModuleInfo] effs)- => Ghci.Ghci- -> (FilePath -> Eff effs a)- -> [Parse.Expression]- -> Eff effs [Statement]-expandMacros ghci expandFile topLevelExprs = do- (stmts, macroDefs) <-- foldM- (\acc@(stmts, macroDefs) expr -> do- expandedExprs <- fullyExpandExpr stmts macroDefs expr- foldM- (\acc' expandedExpr -> do- stmt <- normalizeStatement expandedExpr- case stmt of- SMacroDefinition macroDef ->- pure $ acc' & _2 %~ flip snoc macroDef- _ -> do- case stmt of- SMacroImport macroImport -> do- moduleInfo <-- gets- @ModuleInfo- (Map.filter- (\(moduleId', _) ->- moduleId' == macroImport ^. moduleName))- case listToMaybe $ Map.toList moduleInfo of- Just (dependencyFilePath, (_, isCompiled)) ->- unless isCompiled $ void $- expandFile dependencyFilePath- Nothing -> pure ()- _ -> pure ()- pure $ acc' & _1 %~ flip snoc stmt)- acc- expandedExprs)- ([], [])- topLevelExprs- pure $ stmts <> map (SMacroDefinition . hygenisizeMacroDefinition) macroDefs+typeMacroDefinitions :: [MacroDefinition ann] -> [SMStatement]+typeMacroDefinitions = map mkMacroTypeSignature . getMacroNames where- fullyExpandExpr stmts allMacroDefs expr = do- let program = Parse.topLevelExpressionsToProgram [expr]- expandedExpr <-- exhaustM- (bottomUpTraverse- (\case- Parse.SExpression xs ->- Parse.SExpression <$>- foldM- (\acc x ->- case x of- Parse.SExpression (Parse.Symbol function:args) ->- let maybeMacroDefs =- if isMacroImported function stmts- then Just []- else case lookupMacroDefinitions- function- allMacroDefs of- [] -> Nothing- macroDefs -> Just macroDefs- in case maybeMacroDefs of- Just macroDefs ->- (acc <>) <$>- expandMacroApplication- ghci- function- macroDefs- (filter isStatementNonconflicting stmts)- args- Nothing -> pure $ snoc acc x- _ -> pure $ snoc acc x)- []- xs- x -> pure x))- program- pure $ Parse.programToTopLevelExpressions expandedExpr+ getMacroNames = nub . map (^. functionDefinition . name) +-- | Source metadata is lost.+-- | Use only for logging and such where that doesn't matter.+losslyReconstructMacroCall :: Identifier -> [SM.Expression] -> SM.Expression+losslyReconstructMacroCall macroName args =+ Parse.SExpression+ Nothing+ (Parse.Symbol Nothing (T.unpack macroName) : map (Nothing <$) args)++withExpansionId ::+ SM.Expression+ -> Sem.Sem (Sem.Reader ExpansionId ': effs) a+ -> Sem.Sem 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+ expandMacroApplication ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource] effs)- => Ghci.Ghci+ (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)+ => SourceMetadata -> Identifier- -> [MacroDefinition]- -> [Statement]- -> [Parse.Expression]- -> Eff effs [Parse.Expression]-expandMacroApplication ghci macroName macroDefs auxEnv args = do- macroProgram <- generateMacroProgram macroName macroDefs auxEnv args- newSource <- uncurry3 (evalMacro ghci) macroProgram- Parse.parseMultiple newSource--lookupMacroDefinitions :: Identifier -> [MacroDefinition] -> [MacroDefinition]-lookupMacroDefinitions identifier =- filter (\macroDef -> macroDef ^. functionDefinition . name == identifier)+ -> [SM.Expression]+ -> Sem.Sem effs [SM.Expression]+expandMacroApplication originalAnn macroName args = do+ logStrLn $ "Expanding: " <> toAxel (losslyReconstructMacroCall macroName args)+ filePath' <- Sem.ask @FilePath+ macroProgram <- generateMacroProgram filePath' macroName args+ (tempFilePath, newSource) <-+ uncurry (evalMacro originalAnn macroName args) macroProgram+ logStrLn $ "Result: " <> newSource <> "\n\n"+ parseMultiple (Just tempFilePath) newSource -isMacroDefinitionStatement :: Statement -> Bool+isMacroDefinitionStatement :: Statement ann -> Bool isMacroDefinitionStatement (SMacroDefinition _) = True isMacroDefinitionStatement _ = False evalMacro :: forall effs.- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process] effs)- => Ghci.Ghci- -> String- -> String- -> String- -> Eff effs String-evalMacro ghci astDefinition scaffold macroDefinitionAndEnvironment = do- let macroDefinitionAndEnvironmentFileName =- "AutogeneratedAxelMacroDefinitionAndEnvironment.hs"- let scaffoldModuleName = "AutogeneratedAxelScaffold"- let scaffoldFileName = scaffoldModuleName <.> "hs"- let astDefinitionFileName = "AutogeneratedAxelASTDefinition.hs"+ (Sem.Members '[ Sem.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Sem.Reader Ghcid.Ghci, Sem.Reader FilePath, Sem.Reader ExpansionId] effs)+ => SourceMetadata+ -> Identifier+ -> [SM.Expression]+ -> SM.Output+ -> SM.Output+ -> Sem.Sem effs (FilePath, Text)+evalMacro originalCallAnn macroName args scaffoldProgram macroDefAndEnvProgram = do+ macroDefAndEnvModuleName <- Sem.asks mkMacroDefAndEnvModuleName+ scaffoldModuleName <- Sem.asks mkScaffoldModuleName+ tempDir <- getTempDirectory+ let macroDefAndEnvFileName =+ tempDir </> FilePath macroDefAndEnvModuleName <.> "hs"+ let scaffoldFileName = tempDir </> FilePath scaffoldModuleName <.> "hs"+ let resultFile = tempDir </> FilePath "result.axel" FS.writeFile scaffoldFileName scaffold- FS.writeFile astDefinitionFileName astDefinition- FS.writeFile- macroDefinitionAndEnvironmentFileName- macroDefinitionAndEnvironment- void $ Ghci.exec ghci $- unwords- [ ":l"- , scaffoldFileName- , astDefinitionFileName- , macroDefinitionAndEnvironmentFileName- ]- result <- unlines <$> Ghci.exec ghci ":main"- FS.removeFile astDefinitionFileName- FS.removeFile macroDefinitionAndEnvironmentFileName- FS.removeFile scaffoldFileName- pure result+ FS.writeFile macroDefAndEnvFileName macroDefAndEnv+ let moduleInfo =+ M.fromList $+ map+ (_1 %~ flip replaceExtension "axel")+ [ (scaffoldFileName, (scaffoldModuleName, Just scaffoldProgram))+ , ( macroDefAndEnvFileName+ , (macroDefAndEnvModuleName, Just macroDefAndEnvProgram))+ ]+ ghci <- Sem.ask @Ghcid.Ghci+ loadResult <- Ghci.addFiles ghci [scaffoldFileName, macroDefAndEnvFileName]+ if any ("Ok, " `T.isPrefixOf`) loadResult+ then do+ result <- T.unlines <$> Ghci.exec ghci (scaffoldModuleName <> ".main")+ FS.writeFile resultFile $+ generateExpansionRecord+ originalCallAnn+ macroName+ args+ result+ scaffoldFileName+ macroDefAndEnvFileName+ if any ("*** Exception:" `T.isPrefixOf`) (T.lines result)+ then throwMacroError result+ else pure (resultFile, result)+ else throwMacroError (processErrors moduleInfo $ T.unlines loadResult)+ where+ macroDefAndEnv = SM.raw macroDefAndEnvProgram+ scaffold = SM.raw scaffoldProgram+ getTempDirectory = do+ ExpansionId expansionId <- Sem.ask @ExpansionId+ let dirName = FilePath "axelTemp" </> FilePath expansionId+ FS.createDirectoryIfMissing True dirName+ pure dirName+ throwMacroError msg = do+ originalFilePath <- Sem.ask @FilePath+ Sem.throw $+ MacroError+ originalFilePath+ (losslyReconstructMacroCall macroName args)+ msg++generateExpansionRecord ::+ SourceMetadata+ -> Identifier+ -> [SM.Expression]+ -> Text+ -> FilePath+ -> FilePath+ -> Text+generateExpansionRecord originalAnn macroName args result scaffoldFilePath macroDefAndEnvFilePath =+ T.unlines+ [ result+ , "-- This file is an autogenerated record of a macro call and expansion."+ , "-- It is (likely) not a valid Axel program, so you probably don't want to run it directly."+ , ""+ , "-- The beginning of this file contains the result of the macro invocation at " <>+ locationHint <>+ ":"+ , toAxel (losslyReconstructMacroCall macroName args)+ , ""+ , "-- The macro call itself is transpiled in " <>+ op FilePath (takeFileName scaffoldFilePath) <>+ "."+ , ""+ , "-- To see the (transpiled) modules, definitions, extensions, etc. visible during the expansion, check " <>+ op FilePath (takeFileName macroDefAndEnvFilePath) <>+ "."+ ]+ where+ locationHint =+ case originalAnn of+ Just x -> renderSourcePosition x+ Nothing -> "<unknown>"
src/Axel/Normalize.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-} module Axel.Normalize where +import Axel.Prelude+ import Axel.AST ( CaseBlock(CaseBlock) , DataDeclaration(DataDeclaration)@@ -27,11 +28,12 @@ , RecordDefinition(RecordDefinition) , RecordType(RecordType) , RestrictedImport(RestrictedImport)+ , SMStatement , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition, SMacroImport, SModuleDeclaration, SNewtypeDeclaration, SPragma, SQualifiedImport, SRawStatement, SRestrictedImport, STopLevel, STypeSignature, STypeSynonym, STypeclassDefinition,- STypeclassInstance, SUnrestrictedImport)+ STypeclassInstance) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor) , TypeSignature(TypeSignature)@@ -39,146 +41,186 @@ , TypeclassDefinition(TypeclassDefinition) , TypeclassInstance(TypeclassInstance) )-import Axel.Error (Error(NormalizeError))-import qualified Axel.Parse as Parse+import Axel.Eff.Error (Error(NormalizeError), renderError, unsafeRunError)+import qualified Axel.Parse.AST as Parse ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression, Symbol) )+import qualified Axel.Sourcemap as SM (Expression) -import Control.Monad.Freer (Eff, Member)-import Control.Monad.Freer.Error (throwError)-import qualified Control.Monad.Freer.Error as Effs (Error)+import qualified Data.Text as T +import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+import qualified Polysemy.Reader as Sem++type ExprCtxt = [SM.Expression]++pushCtxt ::+ (Sem.Member (Sem.Reader [SM.Expression]) effs)+ => SM.Expression+ -> Sem.Sem effs a+ -> Sem.Sem effs a+pushCtxt newCtxt = Sem.local (newCtxt :)++withExprCtxt :: Sem.Sem (Sem.Reader [SM.Expression] ': effs) a -> Sem.Sem effs a+withExprCtxt = Sem.runReader []++throwNormalizeError ::+ (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath, Sem.Reader ExprCtxt] effs)+ => Text+ -> Sem.Sem effs a+throwNormalizeError msg = do+ filePath <- Sem.ask @FilePath+ exprCtxt <- Sem.ask @ExprCtxt+ Sem.throw $ NormalizeError filePath msg exprCtxt+ normalizeExpression ::- (Member (Effs.Error Error) effs) => Parse.Expression -> Eff effs Expression-normalizeExpression (Parse.LiteralChar char) = pure $ ELiteral (LChar char)-normalizeExpression (Parse.LiteralInt int) = pure $ ELiteral (LInt int)-normalizeExpression (Parse.LiteralString string) =- pure $ ELiteral (LString string)-normalizeExpression expr@(Parse.SExpression items) =+ (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath, Sem.Reader ExprCtxt] effs)+ => SM.Expression+ -> Sem.Sem effs (Expression (Maybe SM.Expression))+normalizeExpression expr@(Parse.LiteralChar _ char) =+ pure $ ELiteral (LChar (Just expr) char)+normalizeExpression expr@(Parse.LiteralInt _ int) =+ pure $ ELiteral (LInt (Just expr) int)+normalizeExpression expr@(Parse.LiteralString _ string) =+ pure $ ELiteral (LString (Just expr) (T.pack string))+normalizeExpression expr@(Parse.SExpression _ items) =+ pushCtxt expr $ case items of- Parse.Symbol "case":var:cases ->+ Parse.Symbol _ "case":var:cases -> let normalizedCases = traverse (\case- Parse.SExpression [pat, body] ->+ Parse.SExpression _ [pat, body] -> (,) <$> normalizeExpression pat <*> normalizeExpression body- x -> throwError $ NormalizeError "Invalid case!" [x, expr])+ x -> pushCtxt x $ throwNormalizeError "Invalid case!") cases in ECaseBlock <$>- (CaseBlock <$> normalizeExpression var <*> normalizedCases)- [Parse.Symbol "\\", Parse.SExpression args, body] ->+ (CaseBlock (Just expr) <$> normalizeExpression var <*> normalizedCases)+ [Parse.Symbol _ "\\", Parse.SExpression _ args, body] -- TODO Fail if num args /= 2+ -> let normalizedArguments = traverse normalizeExpression args in ELambda <$>- (Lambda <$> normalizedArguments <*> normalizeExpression body)- [Parse.Symbol "if", cond, ifTrue, ifFalse] ->+ (Lambda (Just expr) <$> normalizedArguments <*>+ normalizeExpression body)+ [Parse.Symbol _ "if", cond, ifTrue, ifFalse] -- TODO Fail if num args /= 3+ -> EIfBlock <$>- (IfBlock <$> normalizeExpression cond <*> normalizeExpression ifTrue <*>+ (IfBlock (Just expr) <$> normalizeExpression cond <*>+ normalizeExpression ifTrue <*> normalizeExpression ifFalse)- [Parse.Symbol "let", Parse.SExpression bindings, body] ->+ [Parse.Symbol _ "let", Parse.SExpression _ bindings, body] -- TODO Fail if num args /= 2+ -> let normalizedBindings = traverse (\case- Parse.SExpression [name, value] ->+ Parse.SExpression _ [name, value] -> (,) <$> normalizeExpression name <*> normalizeExpression value- x -> throwError $ NormalizeError "Invalid pattern!" [x, expr])+ x -> pushCtxt x $ throwNormalizeError "Invalid pattern!") bindings in ELetBlock <$>- (LetBlock <$> normalizedBindings <*> normalizeExpression body)- [Parse.Symbol "raw", rawSource] ->+ (LetBlock (Just expr) <$> normalizedBindings <*>+ normalizeExpression body)+ [Parse.Symbol _ "raw", rawSource] -- TODO Fail if num args /= 1+ -> let normalizedRawSource = case rawSource of- Parse.LiteralString x -> pure x+ Parse.LiteralString _ x -> pure x x ->- throwError $- NormalizeError+ pushCtxt x $+ throwNormalizeError "`raw` takes strings representing the code to inject directly."- [x, expr]- in ERawExpression <$> normalizedRawSource- Parse.Symbol "record":bindings ->+ in ERawExpression (Just expr) . T.pack <$> normalizedRawSource+ Parse.Symbol _ "record":bindings -> let normalizedBindings = traverse (\x -> normalizeExpression x >>= \case- EFunctionApplication (FunctionApplication (EIdentifier field) [val]) ->+ EFunctionApplication (FunctionApplication _ (EIdentifier _ field) [val]) -> pure (field, val) _ ->- throwError $- NormalizeError "Invalid field binding!" [x, expr])+ pushCtxt x $ throwNormalizeError "Invalid field binding!") bindings- in ERecordDefinition <$> (RecordDefinition <$> normalizedBindings)- Parse.Symbol "recordType":fields ->+ in ERecordDefinition <$>+ (RecordDefinition (Just expr) <$> normalizedBindings)+ Parse.Symbol _ "recordType":fields -> let normalizedFields = traverse (\x -> normalizeExpression x >>= \case- EFunctionApplication (FunctionApplication (EIdentifier field) [ty]) ->+ EFunctionApplication (FunctionApplication _ (EIdentifier _ field) [ty]) -> pure (field, ty) _ ->- throwError $- NormalizeError "Invalid field definition!" [x, expr])+ pushCtxt x $+ throwNormalizeError "Invalid field definition!") fields- in ERecordType <$> (RecordType <$> normalizedFields)+ in ERecordType <$> (RecordType (Just expr) <$> normalizedFields) fn:args -> EFunctionApplication <$>- (FunctionApplication <$> normalizeExpression fn <*>+ (FunctionApplication (Just expr) <$> normalizeExpression fn <*> traverse normalizeExpression args)- [] -> pure EEmptySExpression-normalizeExpression (Parse.Symbol symbol) = pure $ EIdentifier symbol+ [] -> pure $ EEmptySExpression (Just expr)+normalizeExpression expr@(Parse.Symbol _ symbol) =+ pure $ EIdentifier (Just expr) (T.pack symbol) normalizeFunctionDefinition ::- (Member (Effs.Error Error) effs)- => [Parse.Expression]+ (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath, Sem.Reader ExprCtxt] effs)+ => SM.Expression -> Identifier- -> [Parse.Expression]- -> Parse.Expression- -> [Parse.Expression]- -> Eff effs FunctionDefinition-normalizeFunctionDefinition ctx fnName arguments body whereDefs =- FunctionDefinition fnName <$> traverse normalizeExpression arguments <*>+ -> [SM.Expression]+ -> SM.Expression+ -> [SM.Expression]+ -> Sem.Sem effs (FunctionDefinition (Maybe SM.Expression))+normalizeFunctionDefinition expr fnName arguments body whereDefs =+ FunctionDefinition (Just expr) fnName <$>+ traverse normalizeExpression arguments <*> normalizeExpression body <*> traverse (\x -> normalizeStatement x >>= \case SFunctionDefinition funDef -> pure funDef- _ -> throwError $ NormalizeError "Invalid where binding!" (x : ctx))+ _ -> pushCtxt x $ throwNormalizeError "Invalid where binding!") whereDefs normalizeStatement ::- (Member (Effs.Error Error) effs) => Parse.Expression -> Eff effs Statement-normalizeStatement expr@(Parse.SExpression items) =+ (Sem.Members '[ Sem.Error Error, Sem.Reader FilePath, Sem.Reader ExprCtxt] effs)+ => SM.Expression+ -> Sem.Sem effs SMStatement+normalizeStatement expr@(Parse.SExpression _ items) =+ pushCtxt expr $ case items of- [Parse.Symbol "::", Parse.Symbol fnName, typeDef] ->- STypeSignature <$> (TypeSignature fnName <$> normalizeExpression typeDef)- Parse.Symbol "=":Parse.Symbol fnName:Parse.SExpression arguments:body:whereDefs ->+ [Parse.Symbol _ "::", Parse.Symbol _ fnName, typeDef] ->+ STypeSignature <$>+ (TypeSignature (Just expr) (T.pack fnName) <$> normalizeExpression typeDef)+ Parse.Symbol _ "=":Parse.Symbol _ fnName:Parse.SExpression _ arguments:body:whereDefs -> SFunctionDefinition <$>- normalizeFunctionDefinition [expr] fnName arguments body whereDefs- Parse.Symbol "begin":stmts ->+ normalizeFunctionDefinition expr (T.pack fnName) arguments body whereDefs+ Parse.Symbol _ "begin":stmts -> let normalizedStmts = traverse normalizeStatement stmts- in STopLevel . TopLevel <$> normalizedStmts- Parse.Symbol "class":classConstraints:className:sigs ->+ in STopLevel . TopLevel (Just expr) <$> normalizedStmts+ Parse.Symbol _ "class":classConstraints:className:sigs -> let normalizedConstraints = normalizeExpression classConstraints >>= \case- EFunctionApplication (FunctionApplication (EIdentifier "list") constraints) ->+ EFunctionApplication (FunctionApplication _ (EIdentifier _ "list") constraints) -> pure constraints _ ->- throwError $- NormalizeError "Invalid constraints!" [classConstraints, expr]+ pushCtxt classConstraints $+ throwNormalizeError "Invalid constraints!" normalizedSigs = traverse (\x -> normalizeStatement x >>= \case STypeSignature tySig -> pure tySig _ ->- throwError $- NormalizeError "Invalid type signature!" [x, expr])+ pushCtxt x $ throwNormalizeError "Invalid type signature!") sigs in STypeclassDefinition <$>- (TypeclassDefinition <$> normalizeExpression className <*>+ (TypeclassDefinition (Just expr) <$> normalizeExpression className <*> normalizedConstraints <*> normalizedSigs)- Parse.Symbol "data":typeDef:constructors ->+ Parse.Symbol _ "data":typeDef:constructors -> let normalizedConstructors = traverse (\x ->@@ -186,117 +228,133 @@ EFunctionApplication functionApplication -> pure functionApplication _ ->- throwError $- NormalizeError "Invalid type constructor!" [x, expr])+ pushCtxt x $+ throwNormalizeError "Invalid type constructor!") constructors in normalizeExpression typeDef >>= \case EFunctionApplication typeConstructor -> SDataDeclaration <$>- (DataDeclaration (TypeConstructor typeConstructor) <$>+ (DataDeclaration+ (Just expr)+ (TypeConstructor (Just expr) typeConstructor) <$> normalizedConstructors)- EIdentifier properType ->+ EIdentifier _ properType -> SDataDeclaration <$>- (DataDeclaration (ProperType properType) <$>+ (DataDeclaration (Just expr) (ProperType (Just expr) properType) <$> normalizedConstructors)- _ -> throwError $ NormalizeError "Invalid type!" [typeDef, expr]- [Parse.Symbol "newtype", typeDef, constructor] ->+ _ -> pushCtxt typeDef $ throwNormalizeError "Invalid type!"+ [Parse.Symbol _ "newtype", typeDef, constructor] -> let normalizedConstructor = normalizeExpression constructor >>= \case EFunctionApplication funApp -> pure funApp _ ->- throwError $- NormalizeError "Invalid type constructor!" [constructor, expr]+ pushCtxt constructor $+ throwNormalizeError "Invalid type constructor!" in normalizeExpression typeDef >>= \case EFunctionApplication typeConstructor -> SNewtypeDeclaration <$>- (NewtypeDeclaration (TypeConstructor typeConstructor) <$>+ (NewtypeDeclaration+ (Just expr)+ (TypeConstructor (Just expr) typeConstructor) <$> normalizedConstructor)- EIdentifier properType ->+ EIdentifier _ properType -> SNewtypeDeclaration <$>- (NewtypeDeclaration (ProperType properType) <$>+ (NewtypeDeclaration+ (Just expr)+ (ProperType (Just expr) properType) <$> normalizedConstructor)- _ -> throwError $ NormalizeError "Invalid type!" [typeDef, expr]- [Parse.Symbol "import", Parse.Symbol moduleName, importSpec] ->+ _ -> pushCtxt typeDef $ throwNormalizeError "Invalid type!"+ [Parse.Symbol _ "import", Parse.Symbol _ moduleName, importSpec] -> SRestrictedImport <$>- (RestrictedImport moduleName <$> normalizeImportSpec expr importSpec)- [Parse.Symbol "importm", Parse.Symbol moduleName, macroImportSpec] ->- SMacroImport . MacroImport moduleName <$>- normalizeMacroImportSpec expr macroImportSpec- [Parse.Symbol "importq", Parse.Symbol moduleName, Parse.Symbol alias, importSpec] ->+ (RestrictedImport (Just expr) (T.pack moduleName) <$>+ normalizeImportSpec importSpec)+ [Parse.Symbol _ "importm", Parse.Symbol _ moduleName, macroImportSpec] ->+ SMacroImport . MacroImport (Just expr) (T.pack moduleName) <$>+ normalizeMacroImportSpec macroImportSpec+ [Parse.Symbol _ "importq", Parse.Symbol _ moduleName, Parse.Symbol _ alias, importSpec] -> SQualifiedImport <$>- (QualifiedImport moduleName alias <$> normalizeImportSpec expr importSpec)- [Parse.Symbol "importUnrestricted", Parse.Symbol moduleName] ->- pure $ SUnrestrictedImport moduleName- Parse.Symbol "instance":instanceName:defs ->+ (QualifiedImport (Just expr) (T.pack moduleName) (T.pack alias) <$>+ normalizeImportSpec importSpec)+ Parse.Symbol _ "instance":instanceName:defs -> let normalizedDefs = traverse (\x -> normalizeStatement x >>= \case SFunctionDefinition fnDef -> pure fnDef- _ ->- throwError $ NormalizeError "Invalid definition!" [x, expr])+ _ -> pushCtxt x $ throwNormalizeError "Invalid definition!") defs in STypeclassInstance <$>- (TypeclassInstance <$> normalizeExpression instanceName <*>+ (TypeclassInstance (Just expr) <$> normalizeExpression instanceName <*> normalizedDefs)- [Parse.Symbol "pragma", Parse.LiteralString pragma] ->- pure $ SPragma (Pragma pragma)- Parse.Symbol "=macro":Parse.Symbol macroName:Parse.SExpression arguments:body:whereBindings ->- SMacroDefinition . MacroDefinition <$>- normalizeFunctionDefinition [expr] macroName arguments body whereBindings- [Parse.Symbol "module", Parse.Symbol moduleName] ->- pure $ SModuleDeclaration moduleName- [Parse.Symbol "raw", rawSource] ->+ [Parse.Symbol _ "pragma", Parse.LiteralString _ pragma] ->+ pure $ SPragma (Pragma (Just expr) (T.pack pragma))+ Parse.Symbol _ "=macro":Parse.Symbol _ macroName:Parse.SExpression _ arguments:body:whereBindings ->+ SMacroDefinition . MacroDefinition (Just expr) <$>+ normalizeFunctionDefinition+ expr+ (T.pack macroName)+ arguments+ body+ whereBindings+ [Parse.Symbol _ "module", Parse.Symbol _ moduleName] ->+ pure $ SModuleDeclaration (Just expr) (T.pack moduleName)+ [Parse.Symbol _ "raw", rawSource] -> let normalizedRawSource = case rawSource of- Parse.LiteralString x -> pure x+ Parse.LiteralString _ x -> pure $ T.pack x x ->- throwError $- NormalizeError+ pushCtxt x $+ throwNormalizeError "`raw` takes strings representing the code to inject directly."- [x, expr]- in SRawStatement <$> normalizedRawSource- [Parse.Symbol "type", alias, def] ->+ in SRawStatement (Just expr) <$> normalizedRawSource+ [Parse.Symbol _ "type", alias, def] -> let normalizedAlias = normalizeExpression alias normalizedDef = normalizeExpression def- in STypeSynonym <$> (TypeSynonym <$> normalizedAlias <*> normalizedDef)- _ -> throwError $ NormalizeError "Invalid statement!" [expr]+ in STypeSynonym <$>+ (TypeSynonym (Just expr) <$> normalizedAlias <*> normalizedDef)+ _ -> throwNormalizeError "Invalid statement!" where- normalizeMacroImportSpec ctxt importSpec =+ normalizeMacroImportSpec importSpec = case importSpec of- Parse.SExpression macroImportList ->+ Parse.SExpression _ macroImportList -> traverse (\case- Parse.Symbol import' -> pure import'- x ->- throwError $ NormalizeError "Invalid macro import!" [x, ctxt])+ Parse.Symbol _ import' -> pure $ T.pack import'+ x -> pushCtxt x $ throwNormalizeError "Invalid macro import!") macroImportList x ->- throwError $- NormalizeError "Invalid macro import specification!" [x, ctxt]- normalizeImportSpec ctxt importSpec =+ pushCtxt x $ throwNormalizeError "Invalid macro import specification!"+ normalizeImportSpec importSpec = case importSpec of- Parse.Symbol "all" -> pure ImportAll- Parse.SExpression importList -> normalizeImportList ctxt importList- x ->- throwError $ NormalizeError "Invalid import specification!" [x, ctxt]- normalizeImportList ctxt input =- ImportOnly <$>+ Parse.Symbol _ "all" -> pure $ ImportAll (Just expr)+ Parse.SExpression _ importList -> normalizeImportList importList+ x -> pushCtxt x $ throwNormalizeError "Invalid import specification!"+ normalizeImportList input =+ ImportOnly (Just expr) <$> traverse (\item ->+ pushCtxt item $ case item of- Parse.Symbol import' -> pure $ ImportItem import'- Parse.SExpression (Parse.Symbol type':imports) ->+ Parse.Symbol _ import' ->+ pure $ ImportItem (Just expr) (T.pack import')+ Parse.SExpression _ (Parse.Symbol _ type':imports) -> let normalizedImports = traverse (\case- Parse.Symbol import' -> pure import'+ Parse.Symbol _ import' -> pure $ T.pack import' x ->- throwError $- NormalizeError "Invalid import!" [x, item, ctxt])+ pushCtxt x $ throwNormalizeError "Invalid import!") imports- in ImportType type' <$> normalizedImports- x -> throwError $ NormalizeError "Invalid import!" [x, item, ctxt])+ in ImportType (Just expr) (T.pack type') <$> normalizedImports+ _ -> throwNormalizeError "Invalid import!") input normalizeStatement expr =- throwError $ NormalizeError "Invalid top-level form!" [expr]+ pushCtxt expr $ throwNormalizeError "Invalid top-level form!"++unsafeNormalize ::+ (SM.Expression -> Sem.Sem '[ Sem.Reader ExprCtxt, Sem.Reader FilePath, Sem.Error Error] a)+ -> SM.Expression+ -> a+unsafeNormalize f =+ Sem.run .+ unsafeRunError renderError . Sem.runReader (FilePath "") . withExprCtxt . f
src/Axel/Parse.hs view
@@ -1,204 +1,192 @@--- NOTE Because `Axel.Parse.AST` will be used as the header of auto-generated macro programs,--- it can't have any project-specific dependencies. As such, the instance definition for--- `BottomUp Expression` can't be defined in the same file as `Expression` itself--- (due to the dependency on `BottomUp`). Fortunately, `Axel.Parse.AST` will (should)--- never be imported by itself but only implicitly as part of this module.-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-} -module Axel.Parse- ( module Axel.Parse- , module Axel.Parse.AST- ) where+module Axel.Parse where -import Axel.Error (Error(ParseError), fatal)+import Axel.Prelude --- Re-exporting these so that consumers of parsed ASTs do not need--- to know about the internal file.+import Axel.Eff.Error (Error(ParseError)) import Axel.Haskell.Language (haskellOperatorSymbols, haskellSyntaxSymbols) import Axel.Parse.AST ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression, Symbol)+ , bottomUpFmapSplicing+ , getAnn )-import Axel.Utils.List (takeUntil)-import Axel.Utils.Recursion- ( Recursive(bottomUpFmap, bottomUpTraverse, topDownFmap)+import qualified Axel.Sourcemap as SM (Expression)+import Axel.Sourcemap+ ( Position(Position, _column, _line)+ , SourceMetadata+ , quoteSourceMetadata+ , wrapCompoundExpressions ) -import Control.Monad.Freer (Eff, Member)-import Control.Monad.Freer.Error (throwError)-import qualified Control.Monad.Freer.Error as Effs (Error)+import Control.Applicative ((<|>))+import Control.Lens (op)+import Control.Monad (void) -import Data.Functor.Identity (Identity) import Data.List ((\\))+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.Void (Void) -import Text.Parsec (ParsecT, Stream, (<|>), eof, parse, try)-import Text.Parsec.Char (alphaNum, char, digit, noneOf, oneOf, space, string)-import Text.Parsec.Combinator (many1, optional)-import Text.Parsec.Language (haskellDef)-import Text.Parsec.Prim (many)-import Text.Parsec.Token (makeTokenParser, stringLiteral)+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem --- TODO `Expression` should probably instead be an instance of `Traversable`, use recursion schemes, etc.--- If so, should I provide `toFix` and `fromFix` functions for macros to take advantage of?--- (Maybe all macros have the argument automatically `fromFix`-ed to make consumption simpler?)-instance Recursive Expression where- bottomUpFmap :: (Expression -> Expression) -> Expression -> Expression- bottomUpFmap f x =- f $- case x of- LiteralChar _ -> x- LiteralInt _ -> x- LiteralString _ -> x- SExpression xs -> SExpression (map (bottomUpFmap f) xs)- Symbol _ -> x- bottomUpTraverse ::- (Monad m) => (Expression -> m Expression) -> Expression -> m Expression- bottomUpTraverse f x =- f =<<- case x of- LiteralChar _ -> pure x- LiteralInt _ -> pure x- LiteralString _ -> pure x- SExpression xs -> SExpression <$> traverse (bottomUpTraverse f) xs- Symbol _ -> pure x- topDownFmap :: (Expression -> Expression) -> Expression -> Expression- topDownFmap f x =- case f x of- LiteralChar _ -> x- LiteralInt _ -> x- LiteralString _ -> x- SExpression xs -> SExpression (map (topDownFmap f) xs)- Symbol _ -> x+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P+import qualified Text.Megaparsec.Char.Lexer as P (charLiteral) -parseReadMacro :: String -> String -> ParsecT String u Identity Expression-parseReadMacro prefix wrapper = applyWrapper <$> (string prefix *> expression)- where- applyWrapper x = SExpression [Symbol wrapper, x]+type Parser = P.Parsec Void Text -any' :: (Stream s m Char) => ParsecT s u m Char-any' = noneOf ""+-- Adapted from https://hackage.haskell.org/package/megaparsec-7.0.5/docs/Text-Megaparsec-Char-Lexer.html#v:charLiteral.+stringLiteral :: Parser Text+stringLiteral = T.pack <$> (P.char '"' *> P.manyTill P.charLiteral (P.char '"')) -whitespace :: (Stream s m Char) => ParsecT s u m String-whitespace = many space+ann :: (SourceMetadata -> a -> b) -> Parser a -> Parser b+ann f x = do+ parsecPosition <- P.getSourcePos+ let sourcePosition =+ ( P.sourceName parsecPosition+ , Position+ { _line = P.unPos $ P.sourceLine parsecPosition+ , _column = P.unPos $ P.sourceColumn parsecPosition+ })+ f (Just sourcePosition) <$> x -literalChar :: (Stream s m Char) => ParsecT s u m Expression-literalChar = LiteralChar <$> (string "#\\" *> any')+parseReadMacro :: Text -> Text -> Parser SM.Expression+parseReadMacro prefix wrapper = do+ expr <- P.string prefix *> expression+ ann SExpression (pure [Symbol Nothing (T.unpack wrapper), expr]) -literalInt :: (Stream s m Char) => ParsecT s u m Expression-literalInt = LiteralInt . read <$> many1 digit+eol :: Parser ()+eol = P.try (void P.eol) <|> P.eof -literalList :: ParsecT String u Identity Expression+ignored :: Parser ()+ignored = P.skipMany $ P.try comment <|> void P.spaceChar++literalChar :: Parser SM.Expression+literalChar = ann LiteralChar (P.string "#\\" *> P.anySingle)++literalInt :: Parser SM.Expression+literalInt = ann LiteralInt (read <$> P.some P.digitChar)++literalList :: Parser SM.Expression literalList =- SExpression . (Symbol "list" :) <$> (char '[' *> many item <* char ']')- where- item = try (whitespace *> expression) <|> expression+ ann+ SExpression+ ((Symbol Nothing "list" :) <$>+ (P.char '[' *> P.many sExpressionItem <* P.char ']')) -literalString :: ParsecT String u Identity Expression-literalString = LiteralString <$> stringLiteral (makeTokenParser haskellDef)+literalString :: Parser SM.Expression+literalString = ann LiteralString (T.unpack <$> stringLiteral) -quasiquotedExpression :: ParsecT String u Identity Expression+quasiquotedExpression :: Parser SM.Expression quasiquotedExpression = parseReadMacro "`" "quasiquote" -quotedExpression :: ParsecT String u Identity Expression+quotedExpression :: Parser SM.Expression quotedExpression = parseReadMacro "'" "quote" -sExpressionItem :: ParsecT String u Identity Expression-sExpressionItem = try (whitespace *> expression) <|> expression+sExpressionItem :: Parser SM.Expression+sExpressionItem = ignored *> expression <* ignored -sExpression :: ParsecT String u Identity Expression-sExpression = SExpression <$> (char '(' *> many sExpressionItem <* char ')')+sExpression :: Parser SM.Expression+sExpression =+ ann SExpression (P.char '(' *> P.many sExpressionItem <* P.char ')') -infixSExpression :: ParsecT String u Identity Expression+infixSExpression :: Parser SM.Expression infixSExpression =- SExpression . (Symbol "applyInfix" :) <$>- (char '{' *> many sExpressionItem <* char '}')+ ann+ SExpression+ ((Symbol Nothing "applyInfix" :) <$>+ (P.char '{' *> P.many sExpressionItem <* P.char '}')) -spliceUnquotedExpression :: ParsecT String u Identity Expression+spliceUnquotedExpression :: Parser SM.Expression spliceUnquotedExpression = parseReadMacro "~@" "unquoteSplicing" -symbol :: (Stream s Identity Char) => ParsecT s u Identity Expression+symbol :: Parser SM.Expression symbol =- Symbol <$>- many1- (alphaNum <|> oneOf "'_" <|>- oneOf (map fst haskellSyntaxSymbols \\ syntaxSymbols) <|>- oneOf (map fst haskellOperatorSymbols))+ ann+ Symbol+ (P.some+ (P.try P.alphaNumChar <|> P.try (P.oneOf ['\'', '_']) <|>+ P.try (P.oneOf (map fst haskellSyntaxSymbols \\ syntaxSymbols)) <|>+ P.oneOf (map fst haskellOperatorSymbols))) -unquotedExpression :: ParsecT String u Identity Expression+unquotedExpression :: Parser SM.Expression unquotedExpression = parseReadMacro "~" "unquote" -expression :: ParsecT String u Identity Expression+comment :: Parser ()+comment =+ P.try (P.string "--" *> eol) <|>+ void (P.string "-- " *> P.manyTill (void P.anySingle) eol)++expression :: Parser SM.Expression expression =- literalChar <|> literalInt <|> literalList <|> literalString <|>- quotedExpression <|>- quasiquotedExpression <|>- try spliceUnquotedExpression <|>- unquotedExpression <|>- sExpression <|>- infixSExpression <|>+ P.try literalChar <|> P.try literalInt <|> P.try literalList <|>+ P.try literalString <|>+ P.try quotedExpression <|>+ P.try quasiquotedExpression <|>+ P.try spliceUnquotedExpression <|>+ P.try unquotedExpression <|>+ P.try sExpression <|>+ P.try infixSExpression <|> symbol --- TODO Derive this with Template Haskell (it's really brittle, currently).-quoteParseExpression :: Expression -> Expression-quoteParseExpression (LiteralChar x) =- SExpression [Symbol "AST.LiteralChar", LiteralChar x]-quoteParseExpression (LiteralInt x) =- SExpression [Symbol "AST.LiteralInt", LiteralInt x]-quoteParseExpression (LiteralString x) =- SExpression [Symbol "AST.LiteralString", LiteralString x]-quoteParseExpression (SExpression xs) =+-- Adapted from Appendix A of "Quasiquotation in Lisp" by Alan Bawden.+expandQuasiquote :: SM.Expression -> SM.Expression+expandQuasiquote (SExpression _ [Symbol _ "unquote", expr]) = expr+expandQuasiquote (SExpression _ [Symbol _ "unquoteSplicing", _]) =+ error+ "Illegal splicing unquote at the top level of a quasiquote! (`~@foo is not allowed, but `(~@foo) is.)"+expandQuasiquote (SExpression ann' xs) = SExpression- [ Symbol "AST.SExpression"- , SExpression (Symbol "list" : map quoteParseExpression xs)+ ann'+ [ Symbol ann' "AST.SExpression"+ , quoteSourceMetadata ann'+ , SExpression+ ann'+ [ Symbol ann' "concat"+ , SExpression ann' (Symbol ann' "list" : map expandQuasiquoteInList xs)+ ] ]-quoteParseExpression (Symbol x) =- SExpression [Symbol "AST.Symbol", LiteralString (handleEscapes x)]- where- handleEscapes =- concatMap $ \case- '\\' -> "\\\\"- c -> [c]+expandQuasiquote expr =+ let ann' = getAnn expr+ in SExpression ann' [Symbol ann' "quote", expr] +expandQuasiquoteInList :: SM.Expression -> SM.Expression+expandQuasiquoteInList (SExpression _ [Symbol _ "unquoteSplicing", expr]) =+ let ann' = getAnn expr+ in SExpression ann' [Symbol ann' "AST.toExpressionList", expr]+expandQuasiquoteInList expr =+ let ann' = getAnn expr+ in SExpression ann' [Symbol ann' "list", expandQuasiquote expr]+ parseMultiple ::- (Member (Effs.Error Error) effs) => String -> Eff effs [Expression]-parseMultiple =- either (throwError . ParseError . show) (pure . map expandQuotes) .- parse- (many1 (optional whitespace *> expression <* optional whitespace) <* eof)- ""+ (Sem.Member (Sem.Error Error) effs)+ => Maybe FilePath+ -> Text+ -> Sem.Sem effs [SM.Expression]+parseMultiple maybeFilePath input =+ either throwErr (pure . expandQuasiquotes) $+ P.parse program (T.unpack $ op FilePath filePath) input where- expandQuotes =- topDownFmap+ filePath = fromMaybe (FilePath "") maybeFilePath+ program = P.some (ignored *> expression <* ignored) <* P.eof+ throwErr = Sem.throw . ParseError filePath . T.pack . P.errorBundlePretty+ expandQuasiquotes =+ map $+ bottomUpFmapSplicing (\case- SExpression [Symbol "quote", x] -> quoteParseExpression x- x -> x)--parseSingle :: (Member (Effs.Error Error) effs) => String -> Eff effs Expression-parseSingle input =- parseMultiple input >>= \case- [x] -> pure x- _ -> throwError $ ParseError "Only one expression was expected"--stripComments :: String -> String-stripComments = unlines . map cleanLine . lines- where- cleanLine = takeUntil "--"--parseSource :: (Member (Effs.Error Error) effs) => String -> Eff effs Expression-parseSource input = do- statements <- parseMultiple $ stripComments input- pure $ SExpression (Symbol "begin" : statements)--programToTopLevelExpressions :: Expression -> [Expression]-programToTopLevelExpressions (SExpression (Symbol "begin":stmts)) = stmts-programToTopLevelExpressions _ = fatal "programToTopLevelExpressions" "0001"+ SExpression _ (Symbol _ "quasiquote":xs') -> map expandQuasiquote xs'+ x -> [x]) -topLevelExpressionsToProgram :: [Expression] -> Expression-topLevelExpressionsToProgram stmts = SExpression (Symbol "begin" : stmts)+parseSource ::+ (Sem.Member (Sem.Error Error) effs)+ => Maybe FilePath+ -> Text+ -> Sem.Sem effs SM.Expression+parseSource filePath input =+ wrapCompoundExpressions <$> parseMultiple filePath input syntaxSymbols :: String syntaxSymbols = "()[]{}"
src/Axel/Parse/AST.hs view
@@ -1,73 +1,179 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# 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 Axel.Prelude++import Axel.Utils.Maybe (foldMUntilNothing)+import Axel.Utils.Recursion+ ( Traverse+ , ZipperRecursive(zipperBottomUpTraverse, zipperTopDownTraverse)+ , bottomUpFmap+ )+import Axel.Utils.Text (handleCharEscapes)+import Axel.Utils.Zipper (unsafeDown, unsafeUp)++import Control.Lens ((<|))+import Control.Lens.TH (makePrisms)++import Data.Data (Data)+import Data.Generics.Uniplate.Data ()+import Data.Generics.Uniplate.Zipper+ ( Zipper+ , fromZipper+ , hole+ , replaceHole+ , right+ , zipper+ )+import Data.Hashable (Hashable)+import Data.MonoTraversable (oconcatMap) import Data.Semigroup ((<>))-import Data.Typeable (Typeable)+import qualified Data.Text as T -import System.IO.Unsafe (unsafePerformIO)+import GHC.Generics (Generic) -- TODO `Expression` should probably be `Traversable`, use recursion schemes, etc.--- I should provide `toFix` and `fromFix` functions for macros to take advantage of.+-- 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- = LiteralChar Char- | LiteralInt Int- | LiteralString String- | SExpression [Expression]- | Symbol String- deriving (Eq, Show, Typeable)+-- NOTE We're using `String` instead of `Text` so that we don't have to rely+-- on `Axel.Prelude` in user-facing code.+data Expression ann+ = LiteralChar ann Char+ | LiteralInt ann Int+ | LiteralString ann String+ | SExpression ann [Expression ann]+ | Symbol ann String+ deriving (Eq, Data, Functor, Generic, Show) --- ******************************--- Internal utilities--- ******************************-toAxel :: Expression -> String-toAxel (LiteralChar x) = ['{', x, '}']-toAxel (LiteralInt x) = show x-toAxel (LiteralString xs) = "\"" <> xs <> "\""-toAxel (SExpression xs) = "(" <> unwords (map toAxel xs) <> ")"-toAxel (Symbol x) = x+makePrisms ''Expression --- ******************************--- Macro definition utilities--- ******************************-{-# NOINLINE gensymCounter #-}-gensymCounter :: IORef Int-gensymCounter = unsafePerformIO $ newIORef 0+instance (Hashable ann) => Hashable (Expression ann) -gensym :: IO Expression-gensym = do- suffix <- readIORef gensymCounter- let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" <> show suffix- modifyIORef gensymCounter succ- pure $ Symbol identifier+-- TODO Derive this automatically.+getAnn :: Expression ann -> ann+getAnn (LiteralChar ann _) = ann+getAnn (LiteralInt ann _) = ann+getAnn (LiteralString ann _) = ann+getAnn (SExpression ann _) = ann+getAnn (Symbol ann _) = ann --- | This allows splice-unquoting of both `[Expression]`s and `SExpression`s, without requiring special syntax for each.+instance (Data ann) => ZipperRecursive (Expression ann) where+ zipperBottomUpTraverse ::+ forall m.+ Traverse m (Zipper (Expression ann) (Expression ann)) (Expression ann)+ zipperBottomUpTraverse f = fmap fromZipper . go . zipper+ where+ go ::+ Zipper (Expression ann) (Expression ann)+ -> m (Zipper (Expression ann) (Expression ann))+ go z = do+ let recurse =+ case hole z of+ LiteralChar _ _ -> pure+ LiteralInt _ _ -> pure+ LiteralString _ _ -> pure+ SExpression _ [] -> pure+ SExpression _ _ ->+ fmap unsafeUp . foldMUntilNothing right go . unsafeDown+ Symbol _ _ -> pure+ z' <- recurse z+ x <- f z'+ pure $ replaceHole x z'+ zipperTopDownTraverse ::+ forall m.+ Traverse m (Zipper (Expression ann) (Expression ann)) (Expression ann)+ zipperTopDownTraverse f = fmap fromZipper . go . zipper+ where+ go ::+ Zipper (Expression ann) (Expression ann)+ -> m (Zipper (Expression ann) (Expression ann))+ go z = do+ x <- f z+ let z' = replaceHole x z+ let recurse =+ case x of+ LiteralChar _ _ -> pure+ LiteralInt _ _ -> pure+ LiteralString _ _ -> pure+ SExpression _ [] -> pure+ SExpression _ _ ->+ fmap unsafeUp . foldMUntilNothing right go . unsafeDown+ Symbol _ _ -> pure+ recurse z'++bottomUpFmapSplicing ::+ (Data ann)+ => (Expression ann -> [Expression ann])+ -> Expression ann+ -> Expression ann+bottomUpFmapSplicing f =+ bottomUpFmap $ \case+ SExpression ann' xs -> SExpression ann' $ oconcatMap f xs+ x -> x++toAxel :: Expression ann -> Text+toAxel (LiteralChar _ x) = "#\\" <> T.singleton x+toAxel (LiteralInt _ x) = showText x+toAxel (LiteralString _ xs) = "\"" <> handleCharEscapes (T.pack xs) <> "\""+toAxel (SExpression _ (Symbol _ "applyInfix":xs)) =+ "{" <> T.unwords (map toAxel xs) <> "}"+toAxel (SExpression _ (Symbol _ "list":xs)) =+ "[" <> T.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) = "(" <> T.unwords (map toAxel xs) <> ")"+toAxel (Symbol _ x) = T.pack x++-- NOTE We're using `String` instead of `Text` so that we don't have to rely+-- on `Axel.Prelude` in user-facing code.+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+quoteExpression quoteAnn (LiteralChar ann x) =+ SExpression+ ann+ [Symbol ann "AST.LiteralChar", quoteAnn ann, LiteralChar ann x]+quoteExpression quoteAnn (LiteralInt ann x) =+ SExpression ann [Symbol ann "AST.LiteralInt", quoteAnn ann, LiteralInt ann x]+quoteExpression quoteAnn (LiteralString ann x) =+ SExpression+ ann+ [Symbol ann "AST.LiteralString", quoteAnn ann, LiteralString ann x]+quoteExpression quoteAnn (SExpression ann xs) =+ SExpression+ ann+ [ Symbol ann "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]++-- | This allows splice-unquoting of both `[Expression]`s and `SExpression`s,+-- | without requiring special syntax for each. class ToExpressionList a where- toExpressionList :: a -> [Expression]+ type Annotation a+ toExpressionList :: a -> [Expression (Annotation a)] -instance ToExpressionList [Expression] where- toExpressionList :: [Expression] -> [Expression]+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 where- toExpressionList :: Expression -> [Expression]- toExpressionList (SExpression xs) = xs+-- | 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- (show x <>- " cannot be splice-unquoted, because it is not an s-expression!")--programToTopLevelExpressions :: Expression -> [Expression]-programToTopLevelExpressions (SExpression (Symbol "begin":stmts)) = stmts-programToTopLevelExpressions _ =- error "programToTopLevelExpressions must be passed a top-level program!"--topLevelExpressionsToProgram :: [Expression] -> Expression-topLevelExpressionsToProgram stmts = SExpression (Symbol "begin" : stmts)+ error $+ toAxel x <> " cannot be splice-unquoted, because it is not an s-expression!"
src/Axel/Parse/Args.hs view
@@ -1,38 +1,22 @@ module Axel.Parse.Args where-import Axel- (applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION,- def_AXEL_AUTOGENERATED_MACRO_DEFINITION)-import Data.Semigroup ((<>))-import Options.Applicative- (Parser, argument, command, info, metavar, progDesc, str,- subparser)--data Command = Convert FilePath- | File FilePath- | Project- | Version-commandParser- = (subparser- ((<>) projectCommand- ((<>) fileCommand ((<>) convertCommand versionCommand))))- where convertCommand- = (command "convert"- (info ((<$>) Convert (argument str (metavar "FILE")))- (progDesc "(EXPERIMENTAL) Convert a Haskell file to Axel")))- where- fileCommand- = (command "file"- (info ((<$>) File (argument str (metavar "FILE")))- (progDesc "Build and run a single file")))- where- projectCommand- = (command "project"- (info (pure Project) (progDesc "Build and run the project")))- where- versionCommand- = (command "version"- (info (pure Version)- (progDesc "Display the version of the Axel compiler")))- where--commandParser :: (Parser Command)+import qualified Prelude as GHCPrelude+import qualified Axel.Parse.AST as AST+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 +experimental = ((<>) "(EXPERIMENTAL) ")+experimental :: ((->) String String)+command' name parserInfo = (hsubparser ((<>) (command name parserInfo) (metavar name)))+command' :: ((->) String ((->) (ParserInfo a) (Parser a)))+fileCommandParser = (asum [convertFileCommand,formatFileCommand,runFileCommand]) where {convertFileCommand = (command' "convert" (filePathParser ConvertFile (experimental "Convert a Haskell file to Axel")));runFileCommand = (command' "run" (filePathParser RunFile "Transpile and run an Axel file"));formatFileCommand = (command' "format" (filePathParser FormatFile "Format an Axel file"));filePathParser ctor desc = (info ((<$>) ((.) ctor ((.) FilePath T.pack)) (argument str (metavar "FILE"))) (progDesc desc))}+fileCommandParser :: (Parser FileCommand)+projectCommandParser = (asum [convertProjectCommand,formatProjectCommand,runProjectCommand]) where {convertProjectCommand = (command' "convert" (info (pure ConvertProject) (progDesc "Convert the Haskell project to Axel")));formatProjectCommand = (command' "format" (info (pure FormatProject) (progDesc "Format the project")));runProjectCommand = (command' "run" (info (pure RunProject) (progDesc "Build and run the project")))}+projectCommandParser :: (Parser ProjectCommand)+commandParserInfo = (let {subparsers = (asum [fileCommand,projectCommand,versionCommand])} in (info ((<**>) subparsers helper) fullDesc)) where {fileCommand = (command' "file" (info ((<$>) FileCommand fileCommandParser) (progDesc "Run file-specific commands")));projectCommand = (command' "project" (info ((<$>) ProjectCommand projectCommandParser) (progDesc "Run project-wide commands")));versionCommand = (command' "version" (info (pure Version) (progDesc "Display the version of the Axel compiler")))}+commandParserInfo :: (ParserInfo Command)
+ src/Axel/Prelude.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Prelude+ ( module Axel.Prelude+ , module Data.Text+ , module Prelude+ ) where++import Control.Lens (Wrapped)++import Data.Data (Data)+import Data.Hashable (Hashable)+import Data.Text (Text)+import qualified Data.Text as T++import GHC.Generics (Generic)++import Prelude hiding+ ( FilePath+ , appendFile+ , error+ , errorWithoutStackTrace+ , putStr+ , putStrLn+ , readFile+ , writeFile+ )+import qualified Prelude++newtype FilePath =+ FilePath Text+ deriving (Eq, Generic, Ord, Monoid, Semigroup, Show, Data, Hashable)++instance Wrapped FilePath++showText :: (Show a) => a -> Text+showText = T.pack . show++error :: Text -> a+error = Prelude.error . T.unpack++errorWithoutStackTrace :: Text -> a+errorWithoutStackTrace = Prelude.errorWithoutStackTrace . T.unpack
+ src/Axel/Pretty.hs view
@@ -0,0 +1,106 @@+module Axel.Pretty where++import Axel.Prelude++import Axel.Parse.AST+import Axel.Utils.Foldable (mapWithPrev)+import Axel.Utils.Text (handleCharEscapes)++import Control.Lens (ala, under)++import Data.Maybe (fromMaybe)+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++render :: P.Doc a -> Text+render = P.renderStrict . P.layoutSmart (P.LayoutOptions P.Unbounded)++maximumExpressionLength :: Int+maximumExpressionLength = 60++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) =+ 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+ | otherwise -> multiLiner++privilegedFormToAxelPretty :: [Expression ann] -> P.Doc a+privilegedFormToAxelPretty (Symbol _ "data":name:rest) =+ "data" <+> sexp (toAxelPretty name : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "def":name:tySig:rest) =+ "def" <+>+ P.align+ (P.vsep+ [ (toAxelPretty name <+> toAxelPretty tySig)+ , sexp (map toAxelPretty rest)+ ])+privilegedFormToAxelPretty (Symbol _ "defmacro":name:rest) =+ "defmacro" <+> sexp (toAxelPretty name : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "::":name:rest) =+ "::" <+> sexp (toAxelPretty name : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "=":name:args:rest) =+ "=" <+>+ sexp ((toAxelPretty name <+> toAxelPretty args) : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "=macro":name:args:rest) =+ "=macro" <+>+ sexp ((toAxelPretty name <+> toAxelPretty args) : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "let":bindings:rest) =+ "let" <+> sexp (toAxelPretty bindings : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "if":bindings:rest) =+ "if" <+> sexp (toAxelPretty bindings : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "case":bindings:rest) =+ "case" <+> sexp (toAxelPretty bindings : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "import":name:rest) =+ "import" <+> sexp (toAxelPretty name : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "importq":name:rest) =+ "importq" <+> sexp (toAxelPretty name : map toAxelPretty rest)+privilegedFormToAxelPretty (Symbol _ "importm":name:rest) =+ "importm" <+> sexp (toAxelPretty name : map toAxelPretty rest)+privilegedFormToAxelPretty xs = sexp $ map toAxelPretty xs++toAxelPretty :: Expression ann -> P.Doc a+toAxelPretty (LiteralChar _ x) = "#\\" <> P.pretty x+toAxelPretty (LiteralInt _ x) = P.pretty x+toAxelPretty (LiteralString _ x) =+ P.dquotes $ P.pretty (under unpacked handleCharEscapes x)+toAxelPretty (SExpression _ (Symbol _ "applyInfix":xs)) =+ P.braces $ sexp (map toAxelPretty xs)+toAxelPretty (SExpression _ (Symbol _ "list":xs)) =+ P.brackets $ sexp (map toAxelPretty xs)+toAxelPretty (SExpression _ [Symbol _ "quote", x]) = "\'" <> toAxelPretty x+toAxelPretty (SExpression _ [Symbol _ "quasiquote", x]) = "`" <> toAxelPretty x+toAxelPretty (SExpression _ [Symbol _ "unquote", x]) = "~" <> toAxelPretty x+toAxelPretty (SExpression _ [Symbol _ "unquoteSplicing", x]) =+ "~@" <> toAxelPretty x+toAxelPretty (Symbol _ x) = P.pretty x+toAxelPretty (SExpression _ xs) = P.parens $ privilegedFormToAxelPretty xs++spaceStatements :: [Expression ann] -> [P.Doc a]+spaceStatements =+ mapWithPrev $ \prev x ->+ let isImport (SExpression _ (Symbol _ id':_)) =+ id' `elem` ["import", "importq", "importm"]+ isImport _ = False+ needsSpacing = not $ isImport x && fromMaybe False (isImport <$> prev)+ maybeSpacer =+ if needsSpacing+ then P.line+ else mempty+ in toAxelPretty x <> maybeSpacer++prettifyProgram :: [Expression ann] -> Text+prettifyProgram = render . P.vsep . spaceStatements
+ src/Axel/Sourcemap.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Axel.Sourcemap where++import Axel.Prelude++import Axel.Eff.Lens (assign, modifying)+import Axel.Eff.Loop (breakLoop)+import qualified Axel.Eff.Loop as Effs (runLoop)+import qualified Axel.Parse.AST as Parse+ ( Expression(LiteralInt, LiteralString, SExpression, Symbol)+ , quoteExpression+ )+import Axel.Utils.Foldable (intercalate)+import Axel.Utils.Text (Renderer)+import Axel.Utils.Tuple (Annotated, annotate, annotation, unannotate)++import Control.Lens.Operators ((^.))+import Control.Lens.TH (makeFieldsNoPrefix, makeWrapped)+import Control.Monad (when)++import Data.Data (Data)+import Data.Foldable (for_)+import Data.Hashable (Hashable)+import Data.Map (Map)+import Data.MonoTraversable (oconcatMap, ofor_)+import qualified Data.Text as T++import GHC.Generics (Generic)++import qualified Polysemy as Sem+import qualified Polysemy.State as Sem++data Position =+ Position+ { _line :: Int+ , _column :: Int+ }+ deriving (Data, Eq, Generic, Show)++makeFieldsNoPrefix ''Position++instance Hashable Position++-- NOTE We're using `String` instead of `FilePath` so that we don't have to rely+-- on `Axel.Prelude` or `-XOverloadedStrings` in user-facing code.+type SourcePosition = (String, Position)++renderSourcePosition :: Renderer SourcePosition+renderSourcePosition (filePath, position) =+ let filePath' =+ if filePath == ""+ then "<unknown>"+ else T.pack filePath+ in filePath' <>+ ":" <> showText (position ^. line) <> ":" <> showText (position ^. column)++type SourceMetadata = Maybe SourcePosition++newtype Output =+ Output [Annotated SourceMetadata Text]+ deriving (Eq, Show)++deriving instance Semigroup Output++deriving instance Monoid Output++makeWrapped ''Output++raw :: Output -> Text+raw (Output output) = oconcatMap unannotate output++unassociated :: Text -> Output+unassociated x = Output [annotate Nothing x]++type Expression = Parse.Expression SourceMetadata++isCompoundExpressionWrapperHead :: Expression -> Bool+isCompoundExpressionWrapperHead (Parse.Symbol _ "begin") = True+isCompoundExpressionWrapperHead _ = False++wrapCompoundExpressions :: [Expression] -> Expression+wrapCompoundExpressions stmts =+ Parse.SExpression Nothing (Parse.Symbol Nothing "begin" : stmts)++unwrapCompoundExpressions :: Expression -> [Expression]+unwrapCompoundExpressions (Parse.SExpression _ (Parse.Symbol _ "begin":stmts)) =+ stmts+unwrapCompoundExpressions _ =+ error "unwrapCompoundExpressions must be passed a top-level program!"++data Bracket+ = CurlyBraces+ | DoubleQuotes+ | Parentheses+ | SingleQuotes+ | SquareBrackets++surround :: Bracket -> Output -> Output+surround bracket x =+ let (open, closed) =+ case bracket of+ CurlyBraces -> ("{", "}")+ DoubleQuotes -> ("\"", "\"")+ Parentheses -> ("(", ")")+ SingleQuotes -> ("'", "'")+ SquareBrackets -> ("[", "]")+ in unassociated open <> x <> unassociated closed++data Delimiter+ = Commas+ | Newlines+ | Pipes+ | Semicolons+ | Spaces++delimit :: Delimiter -> [Output] -> Output+delimit delimiter = intercalate (unassociated $ renderDelimiter delimiter)+ where+ renderDelimiter Commas = ","+ renderDelimiter Newlines = "\n"+ renderDelimiter Pipes = "|"+ renderDelimiter Semicolons = ";"+ renderDelimiter Spaces = " "++renderBlock :: [Output] -> Output+renderBlock = surround CurlyBraces . delimit Semicolons++-- | 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}) $+ Effs.runLoop $ do+ for_ output $ \chunk ->+ ofor_ (unannotate chunk) $ \char -> do+ if char == '\n'+ then do+ assign @Position column 0+ modifying @Position line succ+ else modifying @Position column succ+ Sem.get >>= \newSrcPos ->+ when (newSrcPos == transPos) $ breakLoop (Just $ chunk ^. annotation)+ pure Nothing++-- TODO Derive this with Template Haskell (it's currently very brittle)+quoteString :: String -> Expression+quoteString = Parse.LiteralString Nothing++-- TODO Derive this with Template Haskell (it's currently very brittle)+quotePosition :: Position -> Expression+quotePosition sourcePosition =+ Parse.SExpression+ Nothing+ [ Parse.Symbol Nothing "SM.Position"+ , Parse.LiteralInt Nothing (sourcePosition ^. line)+ , Parse.LiteralInt Nothing (sourcePosition ^. column)+ ]++-- TODO Derive this with Template Haskell (it's currently very brittle)+quote2Tuple :: (a -> Expression, b -> Expression) -> (a, b) -> Expression+quote2Tuple (quoterA, quoterB) (a, b) =+ Parse.SExpression Nothing [Parse.Symbol Nothing ",", quoterA a, quoterB b]++-- 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 quoter (Just x) =+ Parse.SExpression Nothing [Parse.Symbol Nothing "GHCPrelude.Just", quoter x]++quoteSourceMetadata :: Maybe SourcePosition -> Expression+quoteSourceMetadata = quoteMaybe $ quote2Tuple (quoteString, quotePosition)++quoteSMExpression :: Expression -> Expression+quoteSMExpression = Parse.quoteExpression quoteSourceMetadata++-- | Keys are the module file paths, and values are (the module name, the transpiled output).+type ModuleInfo = Map FilePath (Text, Maybe Output)
src/Axel/Utils/Debug.hs view
@@ -1,15 +1,20 @@+{- HLINT ignore "Avoid restricted module" -} module Axel.Utils.Debug where +import Axel.Prelude++import qualified Data.Text as T+ import Debug.Trace (trace, traceShow) -unsafeTee :: String -> String-unsafeTee x = trace x x+unsafeTee :: Text -> Text+unsafeTee x = trace (T.unpack x) x -unsafeTeeS :: Show a => a -> a+unsafeTeeS :: (Show a) => a -> a unsafeTeeS x = traceShow x x -unsafeTee' :: (a -> String) -> a -> a-unsafeTee' f x = trace (f x) x+unsafeTee' :: (a -> Text) -> a -> a+unsafeTee' f x = trace (T.unpack $ f x) x -unsafeTeeS' :: Show b => (a -> b) -> a -> a+unsafeTeeS' :: (Show b) => (a -> b) -> a -> a unsafeTeeS' f x = traceShow (f x) x
src/Axel/Utils/Display.hs view
@@ -1,49 +1,15 @@ module Axel.Utils.Display where -import Data.Char (toLower, toUpper)-import Data.List (intercalate)-import Data.Semigroup ((<>))--data Delimiter- = Commas- | Newlines- | Pipes- | Semicolons- | Spaces--delimit :: Delimiter -> [String] -> String-delimit delimiter = intercalate (lookupDelimiter delimiter)- where- lookupDelimiter Commas = ","- lookupDelimiter Newlines = "\n"- lookupDelimiter Pipes = "|"- lookupDelimiter Semicolons = ";"- lookupDelimiter Spaces = " "--lowerFirst :: String -> String-lowerFirst (x:xs) = toLower x : xs-lowerFirst "" = ""--renderBlock :: [String] -> String-renderBlock = surround CurlyBraces . delimit Semicolons+import Axel.Prelude -renderPragma :: String -> String-renderPragma x = "{-# " <> x <> " #-}"+import Axel.Sourcemap (Bracket, Delimiter)+import qualified Axel.Sourcemap as SM -data Bracket- = CurlyBraces- | DoubleQuotes- | Parentheses- | SingleQuotes- | SquareBrackets+surround :: Bracket -> Text -> Text+surround bracket x = SM.raw $ SM.surround bracket $ SM.unassociated x -surround :: Bracket -> String -> String-surround CurlyBraces x = "{" <> x <> "}"-surround DoubleQuotes x = "\"" <> x <> "\""-surround Parentheses x = "(" <> x <> ")"-surround SingleQuotes x = "'" <> x <> "'"-surround SquareBrackets x = "[" <> x <> "]"+delimit :: Delimiter -> [Text] -> Text+delimit delimiter xs = SM.raw $ SM.delimit delimiter $ map SM.unassociated xs -upperFirst :: String -> String-upperFirst (x:xs) = toUpper x : xs-upperFirst "" = ""+renderPragma :: Text -> Text+renderPragma pragma = "{-# " <> pragma <> " #-}"
+ src/Axel/Utils/FilePath.hs view
@@ -0,0 +1,45 @@+module Axel.Utils.FilePath where++import Axel.Prelude++import Control.Lens ((%~), _Wrapping', op, op)++import Data.Function ((&))+import qualified Data.Text as T+import Data.Text.Lens (unpacked)++import qualified System.FilePath as FilePath++(</>) :: FilePath -> FilePath -> FilePath+(FilePath prefix) </> (FilePath suffix) =+ FilePath . T.pack $ (FilePath.</>) (T.unpack prefix) (T.unpack suffix)++(<.>) :: FilePath -> Text -> FilePath+(FilePath prefix) <.> suffix =+ FilePath . T.pack $ (FilePath.<.>) (T.unpack prefix) (T.unpack suffix)++stripExtension :: Text -> FilePath -> Maybe FilePath+stripExtension ext =+ (_Wrapping' FilePath . unpacked) $ FilePath.stripExtension (T.unpack ext)++replaceExtension :: FilePath -> Text -> FilePath+replaceExtension filePath newExt =+ filePath & _Wrapping' FilePath . unpacked %~+ flip FilePath.replaceExtension (T.unpack newExt)++takeFileName :: FilePath -> FilePath+takeFileName = _Wrapping' FilePath . unpacked %~ FilePath.takeFileName++takeBaseName :: FilePath -> FilePath+takeBaseName = _Wrapping' FilePath . unpacked %~ FilePath.takeBaseName++takeDirectory :: FilePath -> FilePath+takeDirectory = _Wrapping' FilePath . unpacked %~ FilePath.takeDirectory++splitDirectories :: FilePath -> [FilePath]+splitDirectories =+ map (FilePath . T.pack) . FilePath.splitDirectories . (T.unpack . op FilePath)++joinPath :: [FilePath] -> FilePath+joinPath =+ (FilePath . T.pack) . FilePath.joinPath . map (T.unpack . op FilePath)
+ src/Axel/Utils/Foldable.hs view
@@ -0,0 +1,17 @@+module Axel.Utils.Foldable where++import Axel.Prelude++-- Adapted from https://github.com/purescript/purescript-foldable-traversable/blob/29d5b873cc86f17e0082d777629819a96bdbc7a1/src/Data/Foldable.purs#L256-L256.+intercalate :: (Foldable f, Monoid m) => m -> f m -> m+intercalate sep xs = snd $ foldl go (True, mempty) xs+ where+ go (isInit, acc) x =+ ( False+ , if isInit+ then x+ else acc <> sep <> x)++mapWithPrev :: (Foldable f) => (Maybe a -> a -> b) -> f a -> [b]+mapWithPrev f =+ snd . foldr (\x (prev, acc) -> (Just x, f prev x : acc)) (Nothing, [])
+ src/Axel/Utils/Json.hs view
@@ -0,0 +1,12 @@+module Axel.Utils.Json where++import Axel.Prelude++import Control.Lens.Iso (iso)+import Control.Lens.Prism (Prism')++import Data.Aeson.Lens (AsNumber, _Number)++-- Adapted from https://hackage.haskell.org/package/lens-aeson-1.0.2/docs/src/Data-Aeson-Lens.html#_Integer.+_Int :: (AsNumber t) => Prism' t Int+_Int = _Number . iso floor fromIntegral
− src/Axel/Utils/Lens.hs
@@ -1,6 +0,0 @@-module Axel.Utils.Lens where--import Control.Lens.Prism (APrism, isn't)--is :: APrism s t a b -> s -> Bool-is k = not . isn't k
src/Axel/Utils/List.hs view
@@ -1,7 +1,58 @@ module Axel.Utils.List where -import Data.List (isPrefixOf)+import Axel.Prelude +import Axel.Utils.Tuple+ ( Annotated+ , annotate+ , annotateWith+ , annotation+ , unannotate+ )++import Control.Lens ((%~), (&), (^.), _1, _2)++import Data.Function (on)+import Data.List (elemIndex, isPrefixOf, sortOn)+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NE (groupBy, head, map)+import Data.Maybe (fromJust, listToMaybe)++head' :: [a] -> Maybe a+head' = listToMaybe++-- Alternatively, `unsafeHead = head`.+unsafeHead :: [a] -> a+unsafeHead = fromJust . listToMaybe++groupAllWith :: (Ord b) => (a -> b) -> [a] -> [Annotated b (NonEmpty a)]+groupAllWith f =+ map extractAnnotation .+ NE.groupBy ((==) `on` (^. annotation)) . map (annotateWith f)+ where+ extractAnnotation xs =+ annotate (NE.head xs ^. annotation) (NE.map unannotate xs)++-- This is not stable in the technical sense of the term, just roughly stable-ish for limited use cases.+stablyGroupAllWith ::+ (Eq a, Ord b) => (a -> b) -> [a] -> [Annotated b (NonEmpty a)]+stablyGroupAllWith f xs =+ map unannotate $+ sortOn (^. annotation) $+ map+ (annotateWith $ \(groupRepresentative :| _, _) ->+ elemIndex groupRepresentative xs) $+ groupAllWith f xs++removeOut :: (Eq a) => (a -> Bool) -> [a] -> ([a], [a])+removeOut f xs =+ let removed = filter f xs+ xs' = filter (not . (`elem` removed)) xs+ in (xs', removed)++remove :: (Eq a) => (a -> Bool) -> [a] -> [a]+remove f xs = fst $ removeOut f xs+ -- https://stackoverflow.com/a/26530188/2391244 takeUntil :: (Eq a) => [a] -> [a] -> [a] takeUntil _ [] = []@@ -10,3 +61,18 @@ if xs `isPrefixOf` (y : ys) then [] else y : takeUntil xs ys++filterMapOut :: (a -> Maybe b) -> [a] -> ([a], [b])+filterMapOut f =+ foldr+ (\x acc ->+ case f x of+ Just x' -> acc & _2 %~ (x' :)+ Nothing -> acc & _1 %~ (x :))+ ([], [])++filterMap :: (a -> Maybe b) -> [a] -> [b]+filterMap f xs = snd $ filterMapOut f xs++only :: a -> [a]+only x = [x]
+ src/Axel/Utils/Maybe.hs view
@@ -0,0 +1,20 @@+module Axel.Utils.Maybe where++import Axel.Prelude++import Data.Functor.Identity (runIdentity)++foldMUntilNothing :: (Monad m) => (a -> Maybe a) -> (a -> m a) -> a -> m a+foldMUntilNothing move modify x = do+ modified <- modify x+ case move modified of+ Nothing -> pure modified+ Just moved -> foldMUntilNothing move modify moved++foldUntilNothing :: (a -> Maybe a) -> (a -> a) -> a -> a+foldUntilNothing move modify =+ runIdentity . foldMUntilNothing move (pure . modify)++whenMaybe :: (Applicative f) => Maybe a -> (a -> f ()) -> f ()+whenMaybe (Just x) f = f x+whenMaybe Nothing _ = pure ()
+ src/Axel/Utils/Monad.hs view
@@ -0,0 +1,6 @@+module Axel.Utils.Monad where++import Axel.Prelude++concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = concat <$> mapM f xs
src/Axel/Utils/Recursion.hs view
@@ -1,5 +1,13 @@+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE UndecidableInstances #-}+ module Axel.Utils.Recursion where +import Axel.Prelude++import Data.Functor.Identity (Identity, runIdentity)+import Data.Generics.Uniplate.Zipper (Zipper, hole)+ exhaustM :: (Eq a, Monad m) => (a -> m a) -> a -> m a exhaustM f x = do result <- f x@@ -7,10 +15,39 @@ then pure result else exhaustM f result --- TODO Use `Fix`-based recursion schemes, implement `Traversable`, and implement `Foldable` instead.+-- TODO Remove dependencies on `Monad` in favor of `Applicative`+-- (which is all that `traverse` requires).+type Traverse m focus a+ = (Monad m) =>+ (focus -> m a) -> a -> m a++type Fmap focus a = (focus -> a) -> a -> a++mkFmapFromTraverse :: Traverse Identity focus a -> Fmap focus a+mkFmapFromTraverse traverseFn f = runIdentity . traverseFn (pure . f)+ class Recursive a where- bottomUpFmap :: (a -> a) -> a -> a- -- TODO Remove dependency on `Monad` in favor of `Applicative`- -- (which is all that the standard `traverse` requires).- bottomUpTraverse :: (Monad m) => (a -> m a) -> a -> m a- topDownFmap :: (a -> a) -> a -> a+ bottomUpTraverse :: Traverse m a a+ topDownTraverse :: Traverse m a a++bottomUpFmap :: (Recursive a) => Fmap a a+bottomUpFmap = mkFmapFromTraverse bottomUpTraverse++topDownFmap :: (Recursive a) => Fmap a a+topDownFmap = mkFmapFromTraverse topDownTraverse++class ZipperRecursive a where+ zipperBottomUpTraverse :: Traverse m (Zipper a a) a+ zipperTopDownTraverse :: Traverse m (Zipper a a) a++instance (ZipperRecursive a) => Recursive a where+ bottomUpTraverse :: Traverse m a a+ bottomUpTraverse f = zipperBottomUpTraverse (f . hole)+ topDownTraverse :: Traverse m a a+ topDownTraverse f = zipperTopDownTraverse (f . hole)++zipperBottomUpFmap :: (ZipperRecursive a) => Fmap (Zipper a a) a+zipperBottomUpFmap = mkFmapFromTraverse zipperBottomUpTraverse++zipperTopDownFmap :: (ZipperRecursive a) => Fmap (Zipper a a) a+zipperTopDownFmap = mkFmapFromTraverse zipperTopDownTraverse
− src/Axel/Utils/String.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Axel.Utils.String where--import qualified Data.Text as T (pack, replace, unpack)--import GHC.Exts (IsString(fromString))--import Language.Haskell.TH.Quote (QuasiQuoter(QuasiQuoter))--replace :: String -> String -> String -> String-replace needle replacement haystack =- T.unpack $ T.replace (T.pack needle) (T.pack replacement) (T.pack haystack)---- Adapted from http://hackage.haskell.org/package/string-quote-0.0.1/docs/src/Data-String-Quote.html#s.-s :: QuasiQuoter-s =- QuasiQuoter- ((\a -> [|fromString a|]) . filter (/= '\r'))- (error "Cannot use s as a pattern")- (error "Cannot use s as a type")- (error "Cannot use s as a dec")
+ src/Axel/Utils/Text.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}++module Axel.Utils.Text where++import Axel.Prelude++import Control.Lens.Combinators (_head)+import Control.Lens.Operators ((%~))++import qualified Data.ByteString.Lazy as B+import Data.Char (chr, ord, toUpper)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import GHC.Exts (IsString(fromString))++import Language.Haskell.TH.Quote (QuasiQuoter(QuasiQuoter))++capitalize :: Text -> Text+capitalize = _head %~ toUpper++-- Adapted from http://hackage.haskell.org/package/string-quote-0.0.1/docs/src/Data-String-Quote.html#s.+s :: QuasiQuoter+s =+ QuasiQuoter+ ((\a -> [|fromString 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+ where+ boldRanges = [('a', 'z', '𝗮'), ('A', 'Z', '𝗔'), ('0', '9', '𝟬')]+ boldDelta x =+ foldl+ (\acc (rangeStart, rangeEnd, boldStart) ->+ if x `elem` [rangeStart .. rangeEnd]+ then ord boldStart - ord rangeStart+ else acc)+ 0+ boldRanges+ boldCharacter x = chr $ (+ boldDelta x) $ ord x++indent :: Int -> Text -> Text+indent width = T.unlines . map (T.replicate width " " <>) . T.lines++type Renderer a = a -> Text++encodeUtf8Lazy :: Text -> B.ByteString+encodeUtf8Lazy = B.fromStrict . T.encodeUtf8++decodeUtf8Lazy :: B.ByteString -> Text+decodeUtf8Lazy = T.decodeUtf8 . B.toStrict
+ src/Axel/Utils/Tuple.hs view
@@ -0,0 +1,32 @@+module Axel.Utils.Tuple where++import Axel.Prelude++import Control.Lens.Operators ((^.))+import Control.Lens.Tuple (_1, _2)+import Control.Lens.Type (Lens)++type Annotated ann a = (a, ann)++annotate :: ann -> a -> Annotated ann a+annotate = flip (,)++annotateWith :: (a -> ann) -> a -> Annotated ann a+annotateWith f x = annotate (f x) x++unannotated :: Lens (Annotated ann a) (Annotated ann a') a a'+unannotated = _1++annotation :: Lens (Annotated ann a) (Annotated ann' a) ann ann'+annotation = _2++unannotate :: Annotated ann a -> a+unannotate = (^. unannotated)++flattenAnnotations ::+ Annotated ann (Annotated ann' a) -> Annotated (ann', ann) a+flattenAnnotations x =+ let outerAnnotation = x ^. annotation+ innerAnnotation = unannotate x ^. annotation+ innerValue = unannotate $ unannotate x+ in annotate (innerAnnotation, outerAnnotation) innerValue
+ src/Axel/Utils/Zipper.hs view
@@ -0,0 +1,20 @@+module Axel.Utils.Zipper where++import Axel.Prelude++import Data.Generics.Uniplate.Operations (Uniplate)+import Data.Generics.Uniplate.Zipper (Zipper, down, left, right, up)++import Data.Maybe (fromJust)++unsafeDown :: (Uniplate a) => Zipper a a -> Zipper a a+unsafeDown = fromJust . down++unsafeLeft :: Zipper a a -> Zipper a a+unsafeLeft = fromJust . left++unsafeRight :: Zipper a a -> Zipper a a+unsafeRight = fromJust . right++unsafeUp :: Zipper a a -> Zipper a a+unsafeUp = fromJust . up
test/Axel/Test/ASTGen.hs view
@@ -1,171 +1,194 @@+{-# LANGUAGE GADTs #-}+ module Axel.Test.ASTGen where +import Axel.Prelude+ import qualified Axel.AST as AST+import qualified Axel.Sourcemap as SM -import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +import TestUtils+ genIdentifier :: (MonadGen m) => m AST.Identifier-genIdentifier = Gen.string (Range.linear 1 5) Gen.alpha+genIdentifier = Gen.text (Range.linear 1 5) Gen.alpha -genLiteral :: (MonadGen m) => m AST.Literal+genLiteral :: (MonadGen m) => m (AST.Literal (Maybe SM.Expression)) genLiteral = Gen.choice- [ AST.LChar <$> Gen.unicode- , AST.LInt <$> Gen.int Range.constantBounded- , AST.LString <$> Gen.string (Range.linear 0 5) Gen.unicode+ [ AST.LChar Nothing <$> Gen.unicode+ , AST.LInt Nothing <$> Gen.int Range.constantBounded+ , AST.LString Nothing <$> Gen.text (Range.linear 0 5) Gen.unicode ] -genCaseBlock :: (MonadGen m) => m AST.CaseBlock+genCaseBlock :: (MonadGen m) => m (AST.CaseBlock (Maybe SM.Expression)) genCaseBlock =- AST.CaseBlock <$> genExpression <*>+ AST.CaseBlock Nothing <$> genExpression <*> Gen.list (Range.linear 0 3) ((,) <$> genExpression <*> genExpression) -genFunctionApplication :: (MonadGen m) => m AST.FunctionApplication+genFunctionApplication ::+ (MonadGen m) => m (AST.FunctionApplication (Maybe SM.Expression)) genFunctionApplication =- AST.FunctionApplication <$> genExpression <*>+ AST.FunctionApplication Nothing <$> genExpression <*> Gen.list (Range.linear 0 3) genExpression -genIfBlock :: (MonadGen m) => m AST.IfBlock-genIfBlock = AST.IfBlock <$> genExpression <*> genExpression <*> genExpression+genIfBlock :: (MonadGen m) => m (AST.IfBlock (Maybe SM.Expression))+genIfBlock =+ AST.IfBlock Nothing <$> genExpression <*> genExpression <*> genExpression -genLambda :: (MonadGen m) => m AST.Lambda+genLambda :: (MonadGen m) => m (AST.Lambda (Maybe SM.Expression)) genLambda =- AST.Lambda <$> Gen.list (Range.linear 0 3) genExpression <*> genExpression+ AST.Lambda Nothing <$> Gen.list (Range.linear 0 3) genExpression <*>+ genExpression -genLetBlock :: (MonadGen m) => m AST.LetBlock+genLetBlock :: (MonadGen m) => m (AST.LetBlock (Maybe SM.Expression)) genLetBlock =- AST.LetBlock <$>+ AST.LetBlock Nothing <$> Gen.list (Range.linear 0 3) ((,) <$> genExpression <*> genExpression) <*> genExpression -genRawExpression :: (MonadGen m) => m String-genRawExpression = Gen.string (Range.linear 0 10) Gen.unicode+genRawExpression :: (MonadGen m) => m Text+genRawExpression = Gen.text (Range.linear 0 10) Gen.unicode -genRecordDefinition :: (MonadGen m) => m AST.RecordDefinition+genRecordDefinition ::+ (MonadGen m) => m (AST.RecordDefinition (Maybe SM.Expression)) genRecordDefinition =- AST.RecordDefinition <$>+ AST.RecordDefinition Nothing <$> Gen.list (Range.linear 0 3) ((,) <$> genIdentifier <*> genExpression) -genRecordType :: (MonadGen m) => m AST.RecordType+genRecordType :: (MonadGen m) => m (AST.RecordType (Maybe SM.Expression)) genRecordType =- AST.RecordType <$>+ AST.RecordType Nothing <$> Gen.list (Range.linear 0 3) ((,) <$> genIdentifier <*> genExpression) -genExpression :: (MonadGen m) => m AST.Expression+genExpression :: (MonadGen m) => m (AST.Expression (Maybe SM.Expression)) genExpression = Gen.recursive Gen.choice- [pure AST.EEmptySExpression, AST.EIdentifier <$> genIdentifier]+ [ pure $ AST.EEmptySExpression Nothing+ , AST.EIdentifier Nothing <$> genIdentifier+ ] [ AST.ECaseBlock <$> genCaseBlock , AST.EFunctionApplication <$> genFunctionApplication , AST.ELambda <$> genLambda , AST.ELetBlock <$> genLetBlock , AST.ELiteral <$> genLiteral , AST.EIfBlock <$> genIfBlock- , AST.ERawExpression <$> genRawExpression+ , AST.ERawExpression Nothing <$> genRawExpression , AST.ERecordDefinition <$> genRecordDefinition , AST.ERecordType <$> genRecordType ] -genTypeDefinition :: (MonadGen m) => m AST.TypeDefinition+genTypeDefinition ::+ (MonadGen m) => m (AST.TypeDefinition (Maybe SM.Expression)) genTypeDefinition = Gen.choice- [ AST.ProperType <$> genIdentifier- , AST.TypeConstructor <$> genFunctionApplication+ [ AST.ProperType Nothing <$> genIdentifier+ , AST.TypeConstructor Nothing <$> genFunctionApplication ] -genDataDeclaration :: (MonadGen m) => m AST.DataDeclaration+genDataDeclaration ::+ (MonadGen m) => m (AST.DataDeclaration (Maybe SM.Expression)) genDataDeclaration =- AST.DataDeclaration <$> genTypeDefinition <*>+ AST.DataDeclaration Nothing <$> genTypeDefinition <*> Gen.list (Range.linear 0 3) genFunctionApplication -genFunctionDefinition :: (MonadGen m) => m AST.FunctionDefinition+genFunctionDefinition ::+ (MonadGen m) => m (AST.FunctionDefinition (Maybe SM.Expression)) genFunctionDefinition =- AST.FunctionDefinition <$> genIdentifier <*>+ AST.FunctionDefinition Nothing <$> genIdentifier <*> Gen.list (Range.linear 0 3) genExpression <*> genExpression <*> Gen.list (Range.linear 0 3) genFunctionDefinition -genPragma :: (MonadGen m) => m AST.Pragma-genPragma = AST.Pragma <$> Gen.string (Range.linear 0 10) Gen.ascii+genPragma :: (MonadGen m) => m (AST.Pragma (Maybe SM.Expression))+genPragma = AST.Pragma Nothing <$> Gen.text (Range.linear 0 10) Gen.ascii -genMacroDefinition :: (MonadGen m) => m AST.MacroDefinition-genMacroDefinition = AST.MacroDefinition <$> genFunctionDefinition+genMacroDefinition ::+ (MonadGen m) => m (AST.MacroDefinition (Maybe SM.Expression))+genMacroDefinition = AST.MacroDefinition Nothing <$> genFunctionDefinition -genImport :: (MonadGen m) => m AST.Import+genImport :: (MonadGen m) => m (AST.Import (Maybe SM.Expression)) genImport = Gen.choice- [ AST.ImportItem <$> genIdentifier- , AST.ImportType <$> genIdentifier <*>+ [ AST.ImportItem Nothing <$> genIdentifier+ , AST.ImportType Nothing <$> genIdentifier <*> Gen.list (Range.linear 0 3) genIdentifier ] -genImportSpecification :: (MonadGen m) => Bool -> m AST.ImportSpecification+genImportSpecification ::+ (MonadGen m) => Bool -> m (AST.ImportSpecification (Maybe SM.Expression)) genImportSpecification importAll = let options =- (AST.ImportOnly <$> Gen.list (Range.linear 0 3) genImport) :- [pure AST.ImportAll | importAll]+ (AST.ImportOnly Nothing <$> Gen.list (Range.linear 0 3) genImport) :+ [pure $ AST.ImportAll Nothing | importAll] in Gen.choice options -genQualifiedImport :: (MonadGen m) => m AST.QualifiedImport+genQualifiedImport ::+ (MonadGen m) => m (AST.QualifiedImport (Maybe SM.Expression)) genQualifiedImport =- AST.QualifiedImport <$> genIdentifier <*> genIdentifier <*>+ AST.QualifiedImport Nothing <$> genIdentifier <*> genIdentifier <*> genImportSpecification True -genMacroImport :: (MonadGen m) => m AST.MacroImport+genMacroImport :: (MonadGen m) => m (AST.MacroImport (Maybe SM.Expression)) genMacroImport =- AST.MacroImport <$> genIdentifier <*>+ AST.MacroImport Nothing <$> genIdentifier <*> Gen.list (Range.linear 0 3) genIdentifier -genNewtypeDeclaration :: (MonadGen m) => m AST.NewtypeDeclaration+genNewtypeDeclaration ::+ (MonadGen m) => m (AST.NewtypeDeclaration (Maybe SM.Expression)) genNewtypeDeclaration =- AST.NewtypeDeclaration <$> genTypeDefinition <*> genFunctionApplication+ AST.NewtypeDeclaration Nothing <$> genTypeDefinition <*>+ genFunctionApplication -genRawStatement :: (MonadGen m) => m String-genRawStatement = Gen.string (Range.linear 0 10) Gen.unicode+genRawStatement :: (MonadGen m) => m Text+genRawStatement = Gen.text (Range.linear 0 10) Gen.unicode -genRestrictedImport :: (MonadGen m) => Bool -> m AST.RestrictedImport+genRestrictedImport ::+ (MonadGen m) => Bool -> m (AST.RestrictedImport (Maybe SM.Expression)) genRestrictedImport importAll =- AST.RestrictedImport <$> genIdentifier <*> genImportSpecification importAll+ AST.RestrictedImport Nothing <$> genIdentifier <*>+ genImportSpecification importAll -genTopLevel :: (MonadGen m) => m AST.TopLevel-genTopLevel = AST.TopLevel <$> Gen.list (Range.linear 0 3) genStatement+genTopLevel :: (MonadGen m) => m (AST.TopLevel (Maybe SM.Expression))+genTopLevel = AST.TopLevel Nothing <$> Gen.list (Range.linear 0 3) genStatement -genTypeclassDefinition :: (MonadGen m) => m AST.TypeclassDefinition+genTypeclassDefinition ::+ (MonadGen m) => m (AST.TypeclassDefinition (Maybe SM.Expression)) genTypeclassDefinition =- AST.TypeclassDefinition <$> genExpression <*>+ AST.TypeclassDefinition Nothing <$> genExpression <*> Gen.list (Range.linear 0 3) genExpression <*> Gen.list (Range.linear 0 3) genTypeSignature -genTypeclassInstance :: (MonadGen m) => m AST.TypeclassInstance+genTypeclassInstance ::+ (MonadGen m) => m (AST.TypeclassInstance (Maybe SM.Expression)) genTypeclassInstance =- AST.TypeclassInstance <$> genExpression <*>+ AST.TypeclassInstance Nothing <$> genExpression <*> Gen.list (Range.linear 0 3) genFunctionDefinition -genTypeSignature :: (MonadGen m) => m AST.TypeSignature-genTypeSignature = AST.TypeSignature <$> genIdentifier <*> genExpression+genTypeSignature :: (MonadGen m) => m (AST.TypeSignature (Maybe SM.Expression))+genTypeSignature = AST.TypeSignature Nothing <$> genIdentifier <*> genExpression -genTypeSynonym :: (MonadGen m) => m AST.TypeSynonym-genTypeSynonym = AST.TypeSynonym <$> genExpression <*> genExpression+genTypeSynonym :: (MonadGen m) => m (AST.TypeSynonym (Maybe SM.Expression))+genTypeSynonym = AST.TypeSynonym Nothing <$> genExpression <*> genExpression -genStatement :: (MonadGen m) => m AST.Statement+genStatement :: (MonadGen m) => m AST.SMStatement genStatement = Gen.recursive Gen.choice [ AST.SDataDeclaration <$> genDataDeclaration , AST.SPragma <$> genPragma , AST.SMacroImport <$> genMacroImport- , AST.SModuleDeclaration <$> genIdentifier+ , AST.SModuleDeclaration Nothing <$> genIdentifier , AST.SQualifiedImport <$> genQualifiedImport- , AST.SRawStatement <$> genRawStatement+ , AST.SRawStatement Nothing <$> genRawStatement , AST.SRestrictedImport <$> genRestrictedImport True , AST.STypeclassDefinition <$> genTypeclassDefinition , AST.STypeclassInstance <$> genTypeclassInstance , AST.STypeSignature <$> genTypeSignature , AST.STypeSynonym <$> genTypeSynonym- , AST.SUnrestrictedImport <$> genIdentifier ] [ AST.STopLevel <$> genTopLevel , AST.SFunctionDefinition <$> genFunctionDefinition
test/Axel/Test/DenormalizeSpec.hs view
@@ -1,32 +1,46 @@-{-# LANGUAGE TypeApplications #-}- module Axel.Test.DenormalizeSpec where +import Axel.Prelude+ import Axel.Denormalize-import Axel.Error+import Axel.Eff.Error as Error import Axel.Normalize+import Axel.Sourcemap as SM import qualified Axel.Test.ASTGen as ASTGen-import Axel.Test.MockUtils -import Control.Monad.Freer as Eff-import Control.Monad.Freer.Error (runError)+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+import qualified Polysemy.Reader as Sem import Hedgehog +import TestUtils++(=$=) :: (Functor f, Eq (f ()), Show (f ()), MonadTest m) => f a -> f b -> m ()+a =$= b = (() <$ a) === (() <$ b)+ hprop_normalizeExpression_is_the_inverse_of_denormalizeExpression :: Property hprop_normalizeExpression_is_the_inverse_of_denormalizeExpression = property $ do expr <- forAll ASTGen.genExpression- expr ===+ expr =$= unwrapRight- (Eff.run . runError @Error $+ renderError+ (Sem.run $+ Sem.runError @Error.Error $+ Sem.runReader (FilePath "") $+ Sem.runReader ([] :: [SM.Expression]) $ normalizeExpression (denormalizeExpression expr)) hprop_normalizeStatement_is_the_inverse_of_denormalizeStatement :: Property hprop_normalizeStatement_is_the_inverse_of_denormalizeStatement = property $ do stmt <- forAll ASTGen.genStatement- stmt ===+ stmt =$= unwrapRight- (Eff.run . runError @Error $+ renderError+ (Sem.run $+ Sem.runError @Error.Error $+ Sem.runReader (FilePath "") $+ Sem.runReader ([] :: [SM.Expression]) $ normalizeStatement (denormalizeStatement stmt))
+ test/Axel/Test/Eff/AppMock.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE GADTs #-}++module Axel.Test.Eff.AppMock where++import Axel.Prelude++import qualified Axel.Eff.Console as Effs+import Axel.Eff.Error as Error+import qualified Axel.Eff.FileSystem as Effs+import qualified Axel.Eff.Ghci as Effs+import qualified Axel.Eff.Log as Effs+import qualified Axel.Eff.Process as Effs+import qualified Axel.Eff.Resource as Effs+import Axel.Test.Eff.ConsoleMock+import Axel.Test.Eff.FileSystemMock+import Axel.Test.Eff.GhciMock+import Axel.Test.Eff.ProcessMock+import Axel.Test.Eff.ResourceMock++import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem++type AppEffs+ = '[ Effs.Log, Effs.Console, Sem.Error Error.Error, Effs.Ghci, Effs.Process, Effs.FileSystem, Effs.Resource, Sem.Error Text]++runApp ::+ (processEffs ~ '[ Effs.FileSystem, Effs.Resource, Sem.Error Text])+ => ConsoleState+ -> FileSystemState+ -> GhciState+ -> ProcessState processEffs+ -> Sem.Sem AppEffs a+ -> ( FileSystemState+ , (ProcessState processEffs, (GhciState, (ConsoleState, a))))+runApp origConsoleState origFSState origGhciState origProcState =+ Sem.run .+ unsafeRunError id .+ runResource .+ runFileSystem origFSState .+ runProcess origProcState .+ runGhci origGhciState .+ unsafeRunError renderError . runConsole origConsoleState . Effs.ignoreLog++evalApp ::+ (processEffs ~ '[ Effs.FileSystem, Effs.Resource, Sem.Error Text])+ => ConsoleState+ -> FileSystemState+ -> GhciState+ -> ProcessState processEffs+ -> Sem.Sem AppEffs a+ -> a+evalApp origConsoleState origFSState origGhciState origProcState =+ snd .+ snd .+ snd . snd . runApp origConsoleState origFSState origGhciState origProcState++evalApp' :: Sem.Sem AppEffs a -> a+evalApp' = evalApp origConsoleState origFSState origGhciState origProcState+ where+ origConsoleState = mkConsoleState+ origFSState = mkFileSystemState []+ origGhciState = mkGhciState []+ origProcState = mkProcessState [] []
test/Axel/Test/Eff/ConsoleMock.hs view
@@ -1,37 +1,40 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-} module Axel.Test.Eff.ConsoleMock where +import Axel.Prelude+ import Axel.Eff.Console as Effs import Control.Lens-import Control.Monad.Freer-import Control.Monad.Freer.State as Effs -newtype ConsoleState = ConsoleState- { _consoleOutput :: String- } deriving (Eq, Show)+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+import qualified Polysemy.State as Sem +import TestUtils++newtype ConsoleState =+ ConsoleState+ { _consoleOutput :: Text+ }+ deriving (Eq, Show)+ makeFieldsNoPrefix ''ConsoleState mkConsoleState :: ConsoleState mkConsoleState = ConsoleState {_consoleOutput = ""} runConsole ::- forall effs a.- ConsoleState- -> Eff (Effs.Console ': effs) a- -> Eff effs (a, ConsoleState)-runConsole origState action = runState origState $ reinterpret go action+ forall effs a. (Sem.Member (Sem.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 where- go :: Console b -> Eff (Effs.State ConsoleState ': effs) b- go (PutStr str) = modify @ConsoleState $ consoleOutput %~ (<> str)+ go :: Console m b -> Sem.Sem (Sem.State ConsoleState ': effs) b+ go GetTerminalSize =+ throwInterpretError "GetTerminalSize" "Not implemented!"+ go (PutStr str) = Sem.modify $ consoleOutput %~ (<> str)
test/Axel/Test/Eff/ConsoleSpec.hs view
@@ -1,13 +1,17 @@+{- HLINT ignore "Redundant do" -} module Axel.Test.Eff.ConsoleSpec where +import Axel.Prelude+ import qualified Axel.Eff.Console as Console import qualified Axel.Test.Eff.ConsoleMock as Mock -import Control.Monad.Freer as Eff+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem import Test.Tasty.Hspec -{-# ANN module "HLint: ignore Redundant do" #-}+import TestUtils spec_Console :: SpecWith () spec_Console =@@ -16,5 +20,7 @@ let action = Console.putStrLn "line1\nline2" let origState = Mock.mkConsoleState let expected = Mock.ConsoleState {Mock._consoleOutput = "line1\nline2\n"}- let result = Eff.run . Mock.runConsole origState $ action- result `shouldBe` ((), expected)+ let result =+ unwrapRight id $+ Sem.run . Sem.runError @Text . Mock.runConsole origState $ action+ result `shouldBe` (expected, ())
test/Axel/Test/Eff/FileSystemMock.hs view
@@ -1,36 +1,29 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} module Axel.Test.Eff.FileSystemMock where +import Axel.Prelude+ import Axel.Eff.FileSystem as Effs-import Axel.Test.MockUtils+import Axel.Utils.FilePath import Control.Lens hiding (children)-import Control.Monad.Freer-import Control.Monad.Freer.Error as Effs-import Control.Monad.Freer.State as Effs import Data.List.Split import Data.Maybe+import qualified Data.Text as T -import System.FilePath+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+import qualified Polysemy.State as Sem +import TestUtils+ data FSNode- = Directory FilePath- [FSNode]- | File FilePath- String+ = Directory FilePath [FSNode]+ | File FilePath Text deriving (Eq, Show) fsPath :: Lens' FSNode FilePath@@ -44,26 +37,28 @@ Directory _ children -> Directory newPath children File _ contents -> File newPath contents) -data FileSystemState = FileSystemState- { _fsCurrentDirectory :: FilePath- , _fsRoot :: FSNode- , _fsTempCounter :: Int- } deriving (Eq, Show)+data FileSystemState =+ FileSystemState+ { _fsCurrentDirectory :: FilePath+ , _fsRoot :: FSNode+ , _fsTempCounter :: Int+ }+ deriving (Eq, Show) makeFieldsNoPrefix ''FileSystemState mkFileSystemState :: [FSNode] -> FileSystemState mkFileSystemState rootContents = FileSystemState- { _fsCurrentDirectory = "/"- , _fsRoot = Directory "/" rootContents+ { _fsCurrentDirectory = FilePath "/"+ , _fsRoot = Directory (FilePath "/") rootContents , _fsTempCounter = 0 } lookupNode :: [FilePath] -> FSNode -> Maybe FSNode lookupNode _ (File _ _) = Nothing lookupNode [] _ = Nothing-lookupNode ["."] rootNode = pure rootNode+lookupNode [FilePath "."] rootNode = pure rootNode lookupNode [segment] (Directory _ rootChildren) = let matchingChildren = filter (\child -> child ^. fsPath == segment) rootChildren@@ -152,51 +147,56 @@ absifyPath :: FilePath -> FilePath -> FilePath absifyPath relativePath currentDirectory = let absolutePath =- case relativePath of+ case T.unpack $ op FilePath relativePath of '/':_ -> relativePath- _ -> "/" </> currentDirectory </> relativePath+ _ -> FilePath "/" </> currentDirectory </> relativePath normalizedSegments = concatMap (\case- [_, ".."] -> []- ["."] -> []+ [_, FilePath ".."] -> []+ [FilePath "."] -> [] xs -> xs) $ chunksOf 2 $ dropLeadingSlash $ splitDirectories absolutePath in case joinPath normalizedSegments of- "" -> "/"+ FilePath "" -> FilePath "/" path -> path where- dropLeadingSlash ("/":xs) = xs- dropLeadingSlash xs = xs+ dropLeadingSlash (FilePath "/":xs) = xs+ dropLeadingSlash x = x absify ::- (Member (Effs.State FileSystemState) effs) => FilePath -> Eff effs FilePath+ (Sem.Member (Sem.State FileSystemState) effs)+ => FilePath+ -> Sem.Sem effs FilePath absify relativePath =- absifyPath relativePath <$> gets @FileSystemState (^. fsCurrentDirectory)+ absifyPath relativePath <$> Sem.gets (^. fsCurrentDirectory) runFileSystem ::- forall effs a. (Member (Effs.Error String) effs)+ forall effs a. (Sem.Member (Sem.Error Text) effs) => FileSystemState- -> Eff (Effs.FileSystem ': effs) a- -> Eff effs (a, FileSystemState)-runFileSystem origState = runState origState . reinterpret go+ -> Sem.Sem (Effs.FileSystem ': effs) a+ -> Sem.Sem effs (FileSystemState, a)+runFileSystem origState = Sem.runState origState . Sem.reinterpret go where- go :: FileSystem ~> Eff (Effs.State FileSystemState ': effs)+ go :: FileSystem m a' -> Sem.Sem (Sem.State FileSystemState ': effs) a'+ go (AppendFile relativePath addedContents) = do+ oldContents <- go $ ReadFile relativePath+ let newContents = oldContents <> addedContents+ go $ WriteFile relativePath newContents go (CopyFile src dest) = do contents <- go $ ReadFile src- go $ WriteFile contents dest+ go $ WriteFile dest contents go (CreateDirectoryIfMissing createParents relativePath) = do path <- absify relativePath- parentNode <- gets @FileSystemState (^. fsRoot . at (takeDirectory path))+ parentNode <- Sem.gets (^. fsRoot . at (takeDirectory path)) case parentNode of Just _ ->- modify @FileSystemState $ fsRoot . at path ?~- Directory (takeFileName path) []+ Sem.modify $ fsRoot . at path ?~ Directory (takeFileName path) [] Nothing -> if createParents- then modify @FileSystemState $ fsRoot %~ \origRoot ->+ then Sem.modify $ fsRoot %~ \origRoot -> fst (foldl (\(root, segments) pathSegment ->@@ -213,54 +213,53 @@ else throwInterpretError @FileSystemState "createDirectoryIfMissing"- ("Missing parents for directory: " <> path)+ ("Missing parents for directory: " <> op FilePath path) go (DoesDirectoryExist relativePath) = do path <- absify relativePath- directoryNode <- gets @FileSystemState (^. fsRoot . at path)+ directoryNode <- Sem.gets (^. fsRoot . at path) pure $ case directoryNode of Just (Directory _ _) -> True _ -> False- go GetCurrentDirectory = gets @FileSystemState (^. fsCurrentDirectory)+ go GetCurrentDirectory = Sem.gets (^. fsCurrentDirectory) go (GetDirectoryContents relativePath) = do path <- absify relativePath- directoryNode <- gets @FileSystemState (^. fsRoot . at path)+ directoryNode <- Sem.gets (^. fsRoot . at path) case directoryNode of Just (Directory _ children) -> pure $ map (^. fsPath) children _ -> throwInterpretError @FileSystemState "getDirectoryContents"- ("No such directory: " <> path)+ ("No such directory: " <> op FilePath path) go GetTemporaryDirectory = do- tempCounter <- gets @FileSystemState (^. fsTempCounter)- modify @FileSystemState $ fsTempCounter %~ (+ 1)- let tempDirName = "/tmp" </> show tempCounter+ tempCounter <- Sem.gets (^. fsTempCounter)+ Sem.modify $ fsTempCounter %~ (+ 1)+ let tempDirName = FilePath "/tmp" </> FilePath (showText tempCounter) go $ CreateDirectoryIfMissing True tempDirName pure tempDirName go (ReadFile relativePath) = do path <- absify relativePath- fileNode <- gets @FileSystemState (^. fsRoot . at path)+ fileNode <- Sem.gets (^. fsRoot . at path) case fileNode of Just (File _ contents) -> pure contents _ -> throwInterpretError @FileSystemState "readFile"- ("No such file: " <> path)+ ("No such file: " <> op FilePath path) go (RemoveFile relativePath) = do path <- absify relativePath- gets @FileSystemState (deleteNode (splitDirectories path) . (^. fsRoot)) >>= \case- Just newRoot -> modify @FileSystemState $ fsRoot .~ newRoot+ Sem.gets (deleteNode (splitDirectories path) . (^. fsRoot)) >>= \case+ Just newRoot -> Sem.modify $ fsRoot .~ newRoot Nothing -> throwInterpretError @FileSystemState "removeFile"- ("No such file: " <> path)+ ("No such file: " <> op FilePath path) go (SetCurrentDirectory relativePath) = do path <- absify relativePath- modify @FileSystemState $ fsCurrentDirectory .~ path+ Sem.modify $ fsCurrentDirectory .~ path go (WriteFile relativePath contents) = do path <- absify relativePath- modify @FileSystemState $ fsRoot . at path ?~- File (takeFileName path) contents+ Sem.modify $ fsRoot . at path ?~ File (takeFileName path) contents
test/Axel/Test/Eff/FileSystemSpec.hs view
@@ -1,76 +1,93 @@+{- HLINT ignore "Redundant do" -} module Axel.Test.Eff.FileSystemSpec where +import Axel.Prelude+ import qualified Axel.Eff.FileSystem as FS import qualified Axel.Test.Eff.FileSystemMock as Mock+import Axel.Utils.FilePath import Control.Lens-import Control.Monad.Freer as Eff-import Control.Monad.Freer.Error -import System.FilePath+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem import Test.Tasty.Hspec -{-# ANN module "HLint: ignore Redundant do" #-}+import TestUtils spec_FileSystem :: SpecWith () spec_FileSystem = do describe "getDirectoryContentsRec" $ do it "gets the files inside a directory and all its subdirectories" $ do- let action = FS.getDirectoryContentsRec "dir1"+ let action = FS.getDirectoryContentsRec (FilePath "dir1") let origState = Mock.mkFileSystemState [ Mock.Directory- "dir1"- [ Mock.File "file1" ""+ (FilePath "dir1")+ [ Mock.File (FilePath "file1") "" , Mock.Directory- "dir2"- [Mock.File "file2" "", Mock.Directory "dir3" []]+ (FilePath "dir2")+ [ Mock.File (FilePath "file2") ""+ , Mock.Directory (FilePath "dir3") []+ ] ] ]- let expected = ["dir1/file1", "dir1/dir2/file2"]- case Eff.run . runError . Mock.runFileSystem origState $ action of- Left err -> expectationFailure err- Right result -> result `shouldBe` (expected, origState)+ let expected = [FilePath "dir1/file1", FilePath "dir1/dir2/file2"]+ case Sem.run . Sem.runError . Mock.runFileSystem origState $ action of+ Left err -> failSpec err+ Right result -> result `shouldBe` (origState, expected) describe "withCurrentDirectory" $ do it "changes the directory and resets it afterwards" $ do let action = do- FS.withCurrentDirectory "inside/subdir" $- FS.writeFile "insideDir" "insideDirContents"- FS.writeFile "outsideDir" "outsideDirContents"+ FS.withCurrentDirectory (FilePath "inside/subdir") $+ FS.writeFile (FilePath "insideDir") "insideDirContents"+ FS.writeFile (FilePath "outsideDir") "outsideDirContents" let origState = Mock.mkFileSystemState [ Mock.Directory- "inside"- [ Mock.Directory "subdir" [Mock.File "bar" "barContents"]- , Mock.File "foo" "fooContents"+ (FilePath "inside")+ [ Mock.Directory+ (FilePath "subdir")+ [Mock.File (FilePath "bar") "barContents"]+ , Mock.File (FilePath "foo") "fooContents" ] ] let expected = origState &- (Mock.fsRoot . at "inside/subdir/insideDir" ?~- Mock.File "insideDir" "insideDirContents") &- (Mock.fsRoot . at "outsideDir" ?~- Mock.File "outsideDir" "outsideDirContents")- case Eff.run . runError . Mock.runFileSystem origState $ action of- Left err -> expectationFailure err- Right result -> result `shouldBe` ((), expected)+ (Mock.fsRoot . at (FilePath "inside/subdir/insideDir") ?~+ 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+ Left err -> failSpec err+ Right result -> result `shouldBe` (expected, ()) describe "withTemporaryDirectory" $ do it "creates a temporary directory and resets the current directory afterwards" $ do let action = do FS.withTemporaryDirectory $ \tempDir ->- FS.writeFile (tempDir </> "insideTemp0") "insideTemp0Contents"+ FS.writeFile+ (tempDir </> FilePath "insideTemp0")+ "insideTemp0Contents" FS.withTemporaryDirectory $ \tempDir ->- FS.writeFile (tempDir </> "insideTemp1") "insideTemp1Contents"+ FS.writeFile+ (tempDir </> FilePath "insideTemp1")+ "insideTemp1Contents" let origState = Mock.mkFileSystemState [] let expected =- origState & (Mock.fsRoot . at "tmp" ?~ Mock.Directory "tmp" []) &- (Mock.fsRoot . at "tmp/0" ?~- Mock.Directory "0" [Mock.File "insideTemp0" "insideTemp0Contents"]) &- (Mock.fsRoot . at "tmp/1" ?~- Mock.Directory "1" [Mock.File "insideTemp1" "insideTemp1Contents"]) &+ origState &+ (Mock.fsRoot . at (FilePath "tmp") ?~+ Mock.Directory (FilePath "tmp") []) &+ (Mock.fsRoot . at (FilePath "tmp/0") ?~+ Mock.Directory+ (FilePath "0")+ [Mock.File (FilePath "insideTemp0") "insideTemp0Contents"]) &+ (Mock.fsRoot . at (FilePath "tmp/1") ?~+ Mock.Directory+ (FilePath "1")+ [Mock.File (FilePath "insideTemp1") "insideTemp1Contents"]) & (Mock.fsTempCounter .~ 2)- case Eff.run . runError . Mock.runFileSystem origState $ action of- Left err -> expectationFailure err- Right result -> result `shouldBe` ((), expected)+ case Sem.run . Sem.runError . Mock.runFileSystem origState $ action of+ Left err -> failSpec err+ Right result -> result `shouldBe` (expected, ())
test/Axel/Test/Eff/GhciMock.hs view
@@ -1,43 +1,40 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-} module Axel.Test.Eff.GhciMock where +import Axel.Prelude+ import Axel.Eff.Ghci as Effs-import Axel.Test.MockUtils import Control.Lens-import Control.Monad.Freer-import Control.Monad.Freer.Error as Effs-import Control.Monad.Freer.State as Effs+import Polysemy+import Polysemy.Error as Effs+import Polysemy.State as Effs -data GhciState = GhciState- { _ghciExecutionLog :: [String]- , _ghciMockResults :: [[String]]- } deriving (Eq, Show)+import TestUtils +data GhciState =+ GhciState+ { _ghciExecutionLog :: [Text]+ , _ghciMockResults :: [[Text]]+ }+ deriving (Eq, Show)+ makeFieldsNoPrefix ''GhciState -mkGhciState :: [[String]] -> GhciState+mkGhciState :: [[Text]] -> GhciState mkGhciState = GhciState [] runGhci ::- forall effs a. (Member (Effs.Error String) effs)+ forall effs a. (Member (Effs.Error Text) effs) => GhciState- -> Eff (Effs.Ghci ': effs) a- -> Eff effs (a, GhciState)+ -> Sem (Effs.Ghci ': effs) a+ -> Sem effs (GhciState, a) runGhci origState action = runState origState $ reinterpret go action where- go :: Ghci b -> Eff (Effs.State GhciState ': effs) b+ go :: Ghci m b -> Sem (Effs.State GhciState ': effs) b go (Exec _ command) = do modify @GhciState $ ghciExecutionLog %~ (|> command) gets @GhciState (uncons . (^. ghciMockResults)) >>= \case@@ -46,5 +43,5 @@ pure mockResult Nothing -> throwInterpretError @GhciState "Exec" "No mock result available"- go Start = undefined- go (Stop _) = undefined+ go Start = throwInterpretError @GhciState "Start" "Not implemented!"+ go (Stop _) = throwInterpretError @GhciState "Stop" "Not implemented!"
test/Axel/Test/Eff/ProcessMock.hs view
@@ -1,38 +1,29 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} module Axel.Test.Eff.ProcessMock where +import Axel.Prelude+ import Axel.Eff.FileSystem as Effs import Axel.Eff.Process as Effs-import Axel.Test.MockUtils import Control.Lens-import Control.Monad.Freer as Eff-import Control.Monad.Freer.Error as Effs-import Control.Monad.Freer.State as Effs +import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+import qualified Polysemy.State as Sem+ import Data.Functor import System.Exit +import TestUtils+ newtype ProcessResult effs =- ProcessResult ((ExitCode, Maybe (String, String)), Eff effs ())+ ProcessResult ((ExitCode, Maybe (Text, Text)), Sem.Sem effs ()) -- | We are pretending that all `ProcessResult`s are unique no matter what, for simplicity's sake. instance Eq (ProcessResult effs) where@@ -44,15 +35,17 @@ show :: ProcessResult effs -> String show _ = "<ProcessResult>" -data ProcessState effs = ProcessState- { _procMockArgs :: [String]- , _procExecutionLog :: [(String, [String], Maybe String)]- , _procMockResults :: [ProcessResult effs]- } deriving (Eq, Show)+data ProcessState effs =+ ProcessState+ { _procMockArgs :: [Text]+ , _procExecutionLog :: [(Text, Maybe Text)]+ , _procMockResults :: [ProcessResult effs]+ }+ deriving (Eq, Show) makeFieldsNoPrefix ''ProcessState -mkProcessState :: [String] -> [ProcessResult effs] -> ProcessState effs+mkProcessState :: [Text] -> [ProcessResult effs] -> ProcessState effs mkProcessState mockArgs mockResults = ProcessState { _procMockArgs = mockArgs@@ -61,48 +54,39 @@ } runProcess ::- forall effs a. (Members '[ Effs.Error String, Effs.FileSystem] effs)+ forall effs a. (Sem.Members '[ Sem.Error Text, Effs.FileSystem] effs) => ProcessState effs- -> Eff (Effs.Process ': effs) a- -> Eff effs (a, ProcessState effs)-runProcess origProcessState = runState origProcessState . reinterpret go+ -> Sem.Sem (Effs.Process ': effs) a+ -> Sem.Sem effs (ProcessState effs, a)+runProcess origProcessState = Sem.runState origProcessState . Sem.reinterpret go where- go :: Process ~> Eff (Effs.State (ProcessState effs) ': effs)- go GetArgs = gets @(ProcessState effs) (^. procMockArgs)- go (RunProcessCreatingStreams cmd args stdin) = do- modify @(ProcessState effs) $- procExecutionLog %~ (|> (cmd, args, Just stdin))- gets @(ProcessState effs) (uncons . (^. procMockResults)) >>= \case+ go :: Process m a' -> Sem.Sem (Sem.State (ProcessState effs) ': effs) a'+ go GetArgs = Sem.gets (^. procMockArgs)+ go (RunProcessCreatingStreams cmd stdin) = do+ Sem.modify $ procExecutionLog %~ (|> (cmd, Just stdin))+ Sem.gets (uncons . (^. procMockResults)) >>= \case Just (ProcessResult (mockResult, fsAction), newMockResults) -> do- modify @(ProcessState effs) $ procMockResults .~ newMockResults+ Sem.modify $ procMockResults .~ newMockResults case mockResult of (exitCode, Just (stdout, stderr)) ->- raise fsAction $> (exitCode, stdout, stderr)+ Sem.raise fsAction $> (exitCode, stdout, stderr) _ -> throwInterpretError- @(ProcessState effs) "RunProcess"- ("Wrong type for mock result: " <> show mockResult)- Nothing ->- throwInterpretError- @(ProcessState effs)- "RunProcess"- "No mock result available"- go (RunProcessInheritingStreams cmd args) = do- modify @(ProcessState effs) $- procExecutionLog %~ (|> (cmd, args, Nothing))- gets @(ProcessState effs) (uncons . (^. procMockResults)) >>= \case+ ("Wrong type for mock result: " <> showText mockResult)+ Nothing -> throwInterpretError "RunProcess" "No mock result available"+ go (RunProcessInheritingStreams cmd) = do+ Sem.modify $ procExecutionLog %~ (|> (cmd, Nothing))+ Sem.gets (uncons . (^. procMockResults)) >>= \case Just (ProcessResult (mockResult, fsAction), newMockResults) -> do- modify @(ProcessState effs) $ procMockResults .~ newMockResults+ Sem.modify $ procMockResults .~ newMockResults case mockResult of- (exitCode, Nothing) -> raise fsAction $> exitCode+ (exitCode, Nothing) -> Sem.raise fsAction $> exitCode _ -> throwInterpretError- @(ProcessState effs) "RunProcessInheritingStreams"- ("Wrong type for mock result: " <> show mockResult)+ ("Wrong type for mock result: " <> showText mockResult) Nothing -> throwInterpretError- @(ProcessState effs) "RunProcessInheritingStreams" "No mock result available"
test/Axel/Test/Eff/ResourceMock.hs view
@@ -1,20 +1,16 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-} module Axel.Test.Eff.ResourceMock where -import Axel.Eff.Resource as Effs+import Axel.Prelude -import Control.Monad.Freer+import Axel.Eff.Resource as Effs+import Axel.Utils.FilePath -import System.FilePath+import qualified Polysemy as Sem -runResource :: forall effs a. Eff (Effs.Resource ': effs) a -> Eff effs a+runResource :: Sem.Sem (Effs.Resource ': effs) a -> Sem.Sem effs a runResource =- interpret $ \case- GetResourcePath (ResourceId resourceId) -> pure ("resources" </> resourceId)+ Sem.interpret $ \case+ GetResourcePath (ResourceId resourceId) ->+ pure (FilePath "dataFiles/resources" </> FilePath resourceId)
test/Axel/Test/Eff/ResourceSpec.hs view
@@ -1,17 +1,18 @@-{-# LANGUAGE FlexibleContexts #-}-+{- HLINT ignore "Redundant do" -} module Axel.Test.Eff.ResourceSpec where +import Axel.Prelude+ import Axel.Eff.Resource as Res import Axel.Test.Eff.FileSystemMock as Mock import Axel.Test.Eff.ResourceMock as Mock -import Control.Monad.Freer as Eff-import qualified Control.Monad.Freer.Error as Effs+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem import Test.Tasty.Hspec -{-# ANN module "HLint: ignore Redundant do" #-}+import TestUtils spec_Resource :: SpecWith () spec_Resource =@@ -21,12 +22,18 @@ let origFSState = Mock.mkFileSystemState [ Mock.Directory- "resources"- [Mock.Directory "resGroup1" [Mock.File "res1" "res1Contents"]]+ (FilePath "dataFiles")+ [ Mock.Directory+ (FilePath "resources")+ [ Mock.Directory+ (FilePath "resGroup1")+ [Mock.File (FilePath "res1") "res1Contents"]+ ]+ ] ] let expected = "res1Contents"- case Eff.run .- Effs.runError . Mock.runFileSystem origFSState . Mock.runResource $+ case Sem.run .+ Sem.runError . Mock.runFileSystem origFSState . Mock.runResource $ action of- Left err -> expectationFailure err- Right result -> result `shouldBe` (expected, origFSState)+ Left err -> failSpec err+ Right result -> result `shouldBe` (origFSState, expected)
− test/Axel/Test/File/FileSpec.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE TypeApplications #-}--module Axel.Test.File.FileSpec where--import Axel.Eff.Console as Console-import Axel.Eff.FileSystem as FS-import Axel.Eff.Ghci as Ghci-import Axel.Eff.Process as Proc-import Axel.Eff.Resource as Res-import Axel.Error as Error-import Axel.Haskell.File-import Axel.Macros--import Control.Monad.Freer as Effs-import Control.Monad.Freer.State (evalState)--import Data.ByteString.Lazy.Char8 as C--import qualified Data.Map as M--import System.FilePath--import Test.Tasty-import Test.Tasty.Golden--test_transpileSource_golden :: IO TestTree-test_transpileSource_golden = do- axelFiles <- findByExtension [".axel_golden"] "test/Axel/Test/File"- pure $- testGroup "`transpileSource` golden tests" $ do- axelFile <- axelFiles- let hsFile = replaceExtension axelFile ".hs_golden"- pure $- goldenVsString- (takeBaseName axelFile)- hsFile- (C.pack <$>- (Effs.runM .- Ghci.runEff .- evalState (M.empty :: ModuleInfo) .- Res.runEff .- Proc.runEff . FS.runEff . Error.runEff @Error . Console.runEff)- (FS.readFile axelFile >>= transpileSource))
test/Axel/Test/Haskell/StackSpec.hs view
@@ -1,59 +1,69 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}+{- HLINT ignore "Redundant do" -} {-# LANGUAGE GADTs #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-} module Axel.Test.Haskell.StackSpec where +import Axel.Prelude++import Axel.Eff.Error import Axel.Eff.FileSystem as FS import Axel.Eff.Process-import Axel.Error 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 Control.Monad.Freer as Eff-import qualified Control.Monad.Freer.Error as Effs +import qualified Data.Map as M++import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+ import System.Exit import Test.Tasty.Hspec -{-# ANN module "HLint: ignore Redundant do" #-}+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" "project/path"+ let action =+ Stack.addStackDependency "foo-1.2.3.4" (FilePath "project/path") let origFSState = Mock.mkFileSystemState [ Mock.Directory- "project"+ (FilePath "project") [ Mock.Directory- "path"- [Mock.File "package.yaml" "dependencies:\n- asdf-5.6.7"]+ (FilePath "path")+ [ Mock.File+ (FilePath "package.yaml")+ "dependencies:\n- asdf-5.6.7"+ ] ] ] let expectedFSState =- origFSState & Mock.fsRoot . at "project/path/package.yaml" ?~+ origFSState & Mock.fsRoot .+ at (FilePath "project/path/package.yaml") ?~ Mock.File- "package.yaml"+ (FilePath "package.yaml") "dependencies:\n- foo-1.2.3.4\n- asdf-5.6.7\n"- case Eff.run . Effs.runError . Mock.runFileSystem origFSState $ action of- Left err -> expectationFailure err- Right ((), result) -> result `shouldBe` expectedFSState+ 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 "project/foo"+ let action = Stack.buildStackProject M.empty (FilePath "project/foo") let origConsoleState = Mock.mkConsoleState let origFSState = Mock.mkFileSystemState- [Mock.Directory "project" [Mock.Directory "foo" []]]+ [ Mock.Directory+ (FilePath "project")+ [Mock.Directory (FilePath "foo") []]+ ] let origProcState = Mock.mkProcessState []@@ -62,16 +72,16 @@ result `shouldBe` () consoleState ^. Mock.consoleOutput `shouldBe` "Building foo...\n" procState ^. Mock.procExecutionLog `shouldBe`- [("stack", ["build"], Just "")]- fsState ^. Mock.fsCurrentDirectory `shouldBe` "/"- case Eff.run . Effs.runError @Error . Effs.runError @String .+ [("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 -> expectationFailure $ show err- Right (Left err) -> expectationFailure err- Right (Right (((x, consoleState), procState), fsState)) ->+ 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@@ -82,35 +92,38 @@ [] [ ProcessResult ( (ExitSuccess, Just ("", ""))- , FS.createDirectoryIfMissing False "newProject")+ , 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]+ [ ("stack new newProject new-template", Just "")+ , ( "stack config set resolver " <> stackageResolverWithAxel , Just "") ]- fsState ^. Mock.fsCurrentDirectory `shouldBe` "/"- fsState ^. Mock.fsRoot . at "newProject" . _Just . Mock.fsPath `shouldBe`- "newProject"- case Eff.run . Effs.runError @Error . Effs.runError @String .+ 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 -> expectationFailure $ show err- Right (Left err) -> expectationFailure err- Right (Right ((x, procState), fsState)) ->+ 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 "project/foo"+ let action = Stack.runStackProject (FilePath "project/foo") let origConsoleState = Mock.mkConsoleState let origFSState = Mock.mkFileSystemState- [Mock.Directory "project" [Mock.Directory "foo" []]]+ [ Mock.Directory+ (FilePath "project")+ [Mock.Directory (FilePath "foo") []]+ ] let origProcState = Mock.mkProcessState []@@ -123,23 +136,25 @@ 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` "/"+ [("stack ide targets", Just ""), ("stack exec foo-exe", Nothing)]+ fsState ^. Mock.fsCurrentDirectory `shouldBe` FilePath "/" consoleState ^. Mock.consoleOutput `shouldBe` "Running foo-exe...\n"- case Eff.run . Effs.runError @Error . Effs.runError @String .+ case Sem.run . Sem.runError @Error . Sem.runError @Text . Mock.runFileSystem origFSState . Mock.runProcess origProcState . Mock.runConsole origConsoleState $ action of- Left err -> expectationFailure $ show err- Right (Left err) -> expectationFailure err- Right (Right (((x, consoleState), procState), fsState)) ->+ Left err -> failSpec $ renderError err+ Right (Left err) -> failSpec err+ Right (Right (fsState, (procState, (consoleState, x)))) -> expectation x (consoleState, fsState, procState) describe "compileFile" $ do it "compiles a file with GHC" $ do- let action = Stack.compileFile @'CreateStreams "projectFoo/app/Main.hs" ""+ let action =+ Stack.compileFile+ @'CreateStreams+ (FilePath "projectFoo/app/Main.hs")+ "" let origFSState = Mock.mkFileSystemState [] let origProcState = Mock.mkProcessState@@ -148,27 +163,25 @@ let expectation stdout (procState, _) = do stdout `shouldBe` "testStdout" procState ^. Mock.procExecutionLog `shouldBe`- [ ( "stack"- , [ "ghc"- , "--resolver"- , Stack.stackageResolverWithAxel- , "--package"- , Stack.axelStackageId- , "--"- , "projectFoo/app/Main.hs"- ]+ [ ( "stack ghc --resolver " <> Stack.stackageResolverWithAxel <>+ " --package " <>+ Stack.axelStackageId <>+ " -- projectFoo/app/Main.hs" , Just "") ]- case Eff.run . Effs.runError @String . Mock.runFileSystem origFSState .+ case Sem.run . Sem.runError @Text . Mock.runFileSystem origFSState . Mock.runProcess origProcState $ action of- Left err -> expectationFailure err- Right (((_, stdout, _), procState), fsState) ->+ Left err -> failSpec err+ Right (fsState, (procState, (_, stdout, _))) -> expectation stdout (procState, fsState) describe "interpretFile" $ do it "interprets a file with GHC" $ do let action =- Stack.interpretFile @'CreateStreams "projectFoo/app/Main.hs" ""+ Stack.interpretFile+ @'CreateStreams+ (FilePath "projectFoo/app/Main.hs")+ "" let origFSState = Mock.mkFileSystemState [] let origProcState = Mock.mkProcessState@@ -177,20 +190,15 @@ let expectation stdout (procState, _) = do stdout `shouldBe` "testStdout" procState ^. Mock.procExecutionLog `shouldBe`- [ ( "stack"- , [ "runghc"- , "--resolver"- , Stack.stackageResolverWithAxel- , "--package"- , Stack.axelStackageId- , "--"- , "projectFoo/app/Main.hs"- ]+ [ ( "stack runghc --resolver " <> Stack.stackageResolverWithAxel <>+ " --package " <>+ Stack.axelStackageId <>+ " -- projectFoo/app/Main.hs" , Just "") ]- case Eff.run . Effs.runError @String . Mock.runFileSystem origFSState .+ case Sem.run . Sem.runError @Text . Mock.runFileSystem origFSState . Mock.runProcess origProcState $ action of- Left err -> expectationFailure err- Right (((_, stdout, _), procState), fsState) ->+ Left err -> failSpec err+ Right (fsState, (procState, (_, stdout, _))) -> expectation stdout (procState, fsState)
+ test/Axel/Test/MacrosSpec.hs view
@@ -0,0 +1,44 @@+{- HLINT ignore "Redundant do" -}+module Axel.Test.MacrosSpec where++import Axel.Prelude++import Axel.Macros+import Axel.Parse.AST+import qualified Axel.Sourcemap as SM+import Axel.Utils.Zipper++import Data.Generics.Uniplate.Zipper++import Test.Tasty.Hspec hiding (focus)++import TestUtils++spec_Macros :: SpecWith ()+spec_Macros = do+ describe "isStatementFocused" $ do+ it "returns if a zipper is focused on a statement's expression" $ do+ let z =+ zipper $+ unsafeParseSingle Nothing "(begin (testStatement1) testStatement2)"+ let testFocusers ::+ Bool+ -> [Zipper SM.Expression SM.Expression -> Zipper SM.Expression SM.Expression]+ -> Expectation+ testFocusers expected =+ mapM_+ (\focus ->+ assertEqual+ ("Failure at " <>+ toAxel (hole $ focus z) <>+ "\n\n\t Context:\thole (focus z)\t\t== " <>+ toAxel (hole $ focus z) <>+ "\n\t\t\thole <$> up (focus z)\t== " <>+ showText (toAxel . hole <$> up (focus z)) <>+ "\n\t\t\tfromZipper z\t\t== " <> toAxel (fromZipper z))+ expected+ (isStatementFocused $ focus z))+ testFocusers+ True+ [unsafeRight . unsafeDown, unsafeRight . unsafeRight . unsafeDown]+ testFocusers False [id, unsafeDown, unsafeDown . unsafeRight . unsafeDown]
− test/Axel/Test/MockUtils.hs
@@ -1,30 +0,0 @@-{-# OPTIONS_GHC "-fno-warn-incomplete-patterns" #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Axel.Test.MockUtils where--import Control.Monad.Freer-import Control.Monad.Freer.Error as Effs-import Control.Monad.Freer.State as Effs--throwInterpretError ::- forall s effs a. (Members '[ Effs.Error String, Effs.State s] effs, Show s)- => String- -> String- -> Eff effs a-throwInterpretError actionName message = do- errorMsg <-- gets @s $ \ctxt ->- "\n----------\nACTION\t" <> actionName <> "\n\nMESSAGE\t" <> message <>- "\n\nSTATE\t" <>- show ctxt <>- "\n----------\n"- throwError errorMsg--unwrapRight :: (Show b) => Either b a -> a-unwrapRight (Right x) = x-unwrapRight (Left x) = error $ show x
test/Axel/Test/NormalizeSpec.hs view
@@ -1,22 +1,29 @@-{-# LANGUAGE TypeApplications #-}- module Axel.Test.NormalizeSpec where +import Axel.Prelude+ import Axel.Denormalize-import Axel.Error+import Axel.Eff.Error as Error import Axel.Normalize-import Axel.Test.MockUtils+import Axel.Sourcemap as SM import qualified Axel.Test.Parse.ASTGen as Parse.ASTGen -import Control.Monad.Freer as Eff-import qualified Control.Monad.Freer.Error as Effs+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem+import qualified Polysemy.Reader as Sem import Hedgehog +import TestUtils+ hprop_denormalizeExpression_is_the_inverse_of_normalizeExpression :: Property hprop_denormalizeExpression_is_the_inverse_of_normalizeExpression = property $ do expr <- forAll Parse.ASTGen.genExpression expr === denormalizeExpression- (unwrapRight $ Eff.run . Effs.runError @Error $ normalizeExpression expr)+ (unwrapRight renderError $+ Sem.run .+ Sem.runError @Error.Error .+ Sem.runReader (FilePath "") . Sem.runReader ([] :: [SM.Expression]) $+ normalizeExpression expr)
test/Axel/Test/Parse/ASTGen.hs view
@@ -1,18 +1,24 @@+{-# LANGUAGE GADTs #-}+ module Axel.Test.Parse.ASTGen where +import Axel.Prelude+ import qualified Axel.Parse.AST as AST+import qualified Axel.Sourcemap as SM -import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -genExpression :: (MonadGen m) => m AST.Expression+import TestUtils++genExpression :: (MonadGen m) => m SM.Expression genExpression = Gen.recursive Gen.choice- [ AST.LiteralChar <$> Gen.unicode- , AST.LiteralInt <$> Gen.int Range.constantBounded- , AST.LiteralString <$> Gen.string (Range.linear 0 5) Gen.unicode- , AST.Symbol <$> Gen.string (Range.linear 0 5) Gen.alpha+ [ AST.LiteralChar Nothing <$> Gen.unicode+ , AST.LiteralInt Nothing <$> Gen.int Range.constantBounded+ , AST.LiteralString Nothing <$> Gen.string (Range.linear 0 5) Gen.unicode+ , AST.Symbol Nothing <$> Gen.string (Range.linear 0 5) Gen.alpha ]- [AST.SExpression <$> Gen.list (Range.linear 0 3) genExpression]+ [AST.SExpression Nothing <$> Gen.list (Range.linear 0 3) genExpression]
+ test/Axel/Test/Parse/ASTSpec.hs view
@@ -0,0 +1,54 @@+{- HLINT ignore "Redundant do" -}+module Axel.Test.Parse.ASTSpec where++import Axel.Prelude++import Axel.Parse.AST+import Axel.Utils.Recursion++import Test.Tasty.Hspec++spec_AST :: SpecWith ()+spec_AST = do+ describe "RecursiveZipper instance" $ do+ it+ "correctly implements zipperBottomUpTraverse (by testing derived methods)" $ do+ let ast :: Expression Int+ ast =+ SExpression+ 1+ [ Symbol 2 "foo"+ , SExpression+ 3+ [ LiteralInt 4 1+ , LiteralChar 5 'a'+ , SExpression 6 [LiteralString 7 "bar"]+ , 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+ bottomUpFmap f ast `shouldBe` (succ <$> ast)+ it "correctly implements zipperTopDownTraverse (by testing derived methods)" $ do+ let ast :: Expression Int+ ast =+ SExpression+ 1+ [ Symbol 2 "foo"+ , SExpression+ 3+ [ LiteralInt 4 1+ , LiteralChar 5 'a'+ , SExpression 6 [LiteralString 7 "bar"]+ , 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)
test/Axel/Test/ParseSpec.hs view
@@ -1,140 +1,76 @@+{- HLINT ignore "Redundant do" -} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeApplications #-} module Axel.Test.ParseSpec where -import Axel.Error+import Axel.Prelude++import Axel.Eff.Error import Axel.Parse-import Axel.Utils.String+import Axel.Parse.AST+import Axel.Utils.Text -import Control.Monad.Freer as Eff-import qualified Control.Monad.Freer.Error as Effs+import qualified Polysemy as Sem+import qualified Polysemy.Error as Sem import Test.Tasty.Hspec -{-# ANN module "HLint: ignore Redundant do" #-}+import TestUtils +parseSingle :: Text -> Expression ()+parseSingle = (() <$) . unsafeParseSingle Nothing+ spec_Parse :: SpecWith () spec_Parse = do describe "parseSingle" $ do it "can parse a character literal" $ do- let result = LiteralChar 'a'- case Eff.run . Effs.runError @Error $ parseSingle "#\\a" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ let result = LiteralChar () 'a'+ parseSingle "#\\a" `shouldBe` result it "can parse an integer literal" $ do- let result = LiteralInt 123- case Eff.run . Effs.runError @Error $ parseSingle "123" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ let result = LiteralInt () 123+ parseSingle "123" `shouldBe` result it "can parse a list literal" $ do- let result = SExpression [Symbol "list", LiteralInt 1, LiteralChar 'a']- case Eff.run . Effs.runError @Error $ parseSingle "[1 #\\a]" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ let result =+ SExpression+ ()+ [Symbol () "list", LiteralInt () 1, LiteralChar () 'a']+ parseSingle "[1 #\\a]" `shouldBe` result it "can parse a string literal" $ do- let result = LiteralString "a \"b"- case Eff.run . Effs.runError @Error $ parseSingle "\"a \\\"b\"" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ let result = LiteralString () "a \"b"+ parseSingle "\"a \\\"b\"" `shouldBe` result it "can parse a quasiquoted expression" $ do let result = SExpression- [Symbol "quasiquote", SExpression [Symbol "foo", Symbol "bar"]]- case Eff.run . Effs.runError @Error $ parseSingle "`(foo bar)" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ ()+ [ Symbol () "quasiquote"+ , SExpression () [Symbol () "foo", Symbol () "bar"]+ ]+ parseSingle "`(foo bar)" `shouldBe` result it "can parse an s-expression" $ do- let result = SExpression [Symbol "foo", Symbol "bar"]- case Eff.run . Effs.runError @Error $ parseSingle "(foo bar)" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ let result = SExpression () [Symbol () "foo", Symbol () "bar"]+ parseSingle "(foo bar)" `shouldBe` result it "can parse a splice-unquoted expression" $ do let result = SExpression- [ Symbol "unquoteSplicing"- , SExpression [Symbol "foo", Symbol "bar"]+ ()+ [ Symbol () "unquoteSplicing"+ , SExpression () [Symbol () "foo", Symbol () "bar"] ]- case Eff.run . Effs.runError @Error $ parseSingle "~@(foo bar)" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ parseSingle "~@(foo bar)" `shouldBe` result it "can parse a symbol" $ do- let result = Symbol "abc123'''"- case Eff.run . Effs.runError @Error $ parseSingle "abc123'''" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ let result = Symbol () "abc123'''"+ parseSingle "abc123'''" `shouldBe` result it "can parse a macro name" $ do- let result = Symbol ",;foo"- case Eff.run . Effs.runError @Error $ parseSingle ",;foo" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ let result = Symbol () ",;foo"+ parseSingle ",;foo" `shouldBe` result it "can parse an unquoted expression" $ do let result = SExpression- [Symbol "unquote", SExpression [Symbol "foo", Symbol "bar"]]- case Eff.run . Effs.runError @Error $ parseSingle "~(foo bar)" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result- it "can quote a character character" $ do- let result = SExpression [Symbol "AST.LiteralChar", LiteralChar 'a']- case Eff.run . Effs.runError @Error $ parseSingle "'#\\a" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result- it "can quote an integer literal" $ do- let result = SExpression [Symbol "AST.LiteralInt", LiteralInt 123]- case Eff.run . Effs.runError @Error $ parseSingle "'123" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result- it "can quote a list literal" $ do- let result =- SExpression- [ Symbol "AST.SExpression"- , SExpression- [ Symbol "list"- , SExpression [Symbol "AST.Symbol", LiteralString "list"]- , SExpression [Symbol "AST.LiteralInt", LiteralInt 1]- , SExpression [Symbol "AST.LiteralInt", LiteralInt 2]- ]- ]- case Eff.run . Effs.runError @Error $ parseSingle "'[1 2]" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result- it "can quote a string literal" $ do- let result = SExpression [Symbol "AST.LiteralString", LiteralString "foo"]- case Eff.run . Effs.runError @Error $ parseSingle "'\"foo\"" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result- it "can quote an s-expression" $ do- let result =- SExpression- [ Symbol "AST.SExpression"- , SExpression- [ Symbol "list"- , SExpression [Symbol "AST.LiteralInt", LiteralInt 1]- , SExpression [Symbol "AST.LiteralInt", LiteralInt 2]- ]- ]- case Eff.run . Effs.runError @Error $ parseSingle "'(1 2)" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result- it "can quote a symbol" $ do- let result = SExpression [Symbol "AST.Symbol", LiteralString "foo"]- case Eff.run . Effs.runError @Error $ parseSingle "'foo" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result- it "can quote a quoted expression" $ do- let result =- SExpression- [ Symbol "AST.SExpression"- , SExpression- [ Symbol "list"- , SExpression [Symbol "AST.Symbol", LiteralString "quote"]- , SExpression [Symbol "AST.Symbol", LiteralString "foo"]- ]+ ()+ [ Symbol () "unquote"+ , SExpression () [Symbol () "foo", Symbol () "bar"] ]- case Eff.run . Effs.runError @Error $ parseSingle "''foo" of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ parseSingle "~(foo bar)" `shouldBe` result describe "parseMultiple" $ do it "can parse multiple expressions" $ do let input =@@ -148,25 +84,48 @@ |] let result = [ SExpression- [Symbol "foo", LiteralInt 1, LiteralInt 2, LiteralInt 3]- , SExpression [Symbol "bar", Symbol "x", Symbol "y", Symbol "z"]+ ()+ [ Symbol () "foo"+ , LiteralInt () 1+ , LiteralInt () 2+ , LiteralInt () 3+ ]+ , SExpression+ ()+ [Symbol () "bar", Symbol () "x", Symbol () "y", Symbol () "z"] ]- case Eff.run . Effs.runError @Error $ parseMultiple input of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ case Sem.run . Sem.runError $ parseMultiple Nothing input of+ Left err -> failSpec $ renderError err+ Right x -> map (() <$) x `shouldBe` result describe "parseSource" $ do it "can parse a source file" $ do let input = [s| (foo 1 2 3) -- This is a comment -- Another comment! (bar x y z)+(end of line comment) --+(butThis-->IsASingleSymbol) |] let result = SExpression- [ Symbol "begin"+ ()+ [ Symbol () "begin" , SExpression- [Symbol "foo", LiteralInt 1, LiteralInt 2, LiteralInt 3]+ ()+ [ Symbol () "foo"+ , LiteralInt () 1+ , LiteralInt () 2+ , LiteralInt () 3+ ]+ , SExpression+ ()+ [ Symbol () "end"+ , Symbol () "of"+ , Symbol () "line"+ , Symbol () "comment"+ ]+ , SExpression () [Symbol () "butThis-->IsASingleSymbol"] ]- case Eff.run . Effs.runError @Error $ parseSource input of- Left err -> expectationFailure $ show err- Right x -> x `shouldBe` result+ case Sem.run . Sem.runError $ parseSource Nothing input of+ Left err -> failSpec $ renderError err+ Right x -> () <$ x `shouldBe` result
+ test/Axel/Test/SourcemapSpec.hs view
@@ -0,0 +1,43 @@+{- HLINT ignore "Redundant do" -}+module Axel.Test.SourcemapSpec where++import Axel.Prelude+import Axel.Sourcemap++import Data.Foldable++import Test.Tasty.Hspec++spec_Sourcemap :: SpecWith ()+spec_Sourcemap = do+ describe "findOriginalPosition" $ -- TODO Convert these into property tests+ do+ let (output, line', column') `was` expected =+ findOriginalPosition output (Position line' column') `shouldBe`+ expected+ context "output is empty" $ do+ it "fails" $ do+ ([], 1, 1) `was` (Nothing :: Maybe ())+ ([("", ()), ("", ())], 1, 1) `was` Nothing+ context "output has multiple lines" $ do+ it "can map each column on each line" $ do+ let output =+ [ ("some", 1)+ , (" ", 2)+ , ("string\n", 3)+ , ("foo", 4)+ , ("\n", 5)+ , ("foo\nquux\n", 6)+ ]+ for_ [1 .. 4] $ \i -> (output, 1, i) `was` Just (1 :: Int)+ for_ [5 .. 6] $ \i -> (output, 1, i) `was` Just (2 :: Int)+ for_ [7 .. 12] $ \i -> (output, 1, i) `was` Just (3 :: Int)+ (output, 1, 13) `was` Nothing+ for_ [1 .. 3] $ \i -> (output, 2, i) `was` Just (4 :: Int)+ for_ [4 .. 4] $ \i -> (output, 2, i) `was` Nothing+ (output, 2, 5) `was` Nothing+ for_ [1 .. 3] $ \i -> (output, 3, i) `was` Just (6 :: Int)+ (output, 3, 4) `was` Nothing+ for_ [1 .. 4] $ \i -> (output, 4, i) `was` Just (6 :: Int)+ (output, 4, 5) `was` Nothing+ (output, 5, 1) `was` Nothing
+ test/Axel/Test/Transpilation/TranspilationSpec.hs view
@@ -0,0 +1,65 @@+module Axel.Test.Transpilation.TranspilationSpec 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 Polysemy as Sem+import qualified Polysemy.State as Sem++import Test.Tasty+import Test.Tasty.Golden++runApp :: Sem.Sem AppEffs a -> IO a+runApp =+ Sem.runM .+ Effs.runTime .+ Effs.runRandom .+ Effs.runResource .+ Effs.runProcess .+ Effs.runGhci .+ Effs.runFileSystem .+ Effs.unsafeRunError Effs.renderError . Effs.runConsole . Effs.ignoreLog++test_transpilation_golden :: IO TestTree+test_transpilation_golden = do+ axelFiles <-+ map (FilePath . T.pack) <$>+ findByExtension [".axel_golden"] "test/Axel/Test/Transpilation"+ pure $+ testGroup "transpilation golden tests" $ do+ axelFile <- axelFiles+ let hsFile = replaceExtension axelFile "hs_golden"+ let transpiled = do+ axelSource <- T.readFile $ T.unpack (op FilePath axelFile)+ output <-+ runApp $+ Sem.evalState (M.empty :: ModuleInfo) $+ Ghci.withGhci $ transpileSource (takeBaseName axelFile) axelSource+ let newSource = encodeUtf8Lazy $ SM.raw output+ pure newSource+ pure $+ goldenVsString+ (T.unpack . op FilePath $ takeBaseName axelFile)+ (T.unpack . op FilePath $ hsFile)+ transpiled
+ test/Axel/Test/Utils/ListSpec.hs view
@@ -0,0 +1,19 @@+{- HLINT ignore "Redundant do" -}+module Axel.Test.Utils.ListSpec where++import Axel.Prelude++import Axel.Utils.List++import Test.Tasty.Hspec++spec_List :: SpecWith ()+spec_List = do+ describe "filterMapOut" $ do+ it "correctly partitions its input" $ do+ let f :: Int -> Maybe Text+ f n =+ if n `mod` 2 == 0+ 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
@@ -0,0 +1,45 @@+{- HLINT ignore "Redundant do" -}+module Axel.Test.Utils.MaybeSpec where++import Axel.Prelude++import Axel.Utils.Maybe+import Axel.Utils.Zipper++import Data.Char+import Data.Data+import Data.Generics.Uniplate.Data ()+import Data.Generics.Uniplate.Zipper+import qualified Data.Text as T++import Test.Tasty.Hspec++data MockAST+ = SExp [MockAST]+ | Symbol Text+ deriving (Data, Eq, Show)++spec_Maybe :: SpecWith ()+spec_Maybe = do+ describe "foldUntilNothing" $ do+ it "works with basic function to be folded" $ do+ let modify :: Int -> Int+ modify = (+ 2)+ let move n =+ if n < 5+ then Just $ n - 1+ else Nothing+ foldUntilNothing move modify 0 `shouldBe` 5+ it "works as expected with AST-traversing zippers" $ do+ let modify z =+ replaceHole+ (case hole z of+ SExp xs -> SExp xs+ Symbol x -> Symbol $ T.map toUpper x)+ z+ in (fromZipper .+ foldUntilNothing right modify .+ unsafeDown . unsafeRight . unsafeDown . zipper)+ (SExp+ [Symbol "unchanged", SExp [Symbol "both", Symbol "capitalized"]]) `shouldBe`+ SExp [Symbol "unchanged", SExp [Symbol "BOTH", Symbol "CAPITALIZED"]]
+ test/TestUtils.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC "-fno-warn-incomplete-patterns" #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TestUtils where++import Axel.Prelude++import Axel.Eff.Error+import Axel.Parse+import Axel.Sourcemap as SM+import Axel.Utils.Text++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 Hedgehog hiding (MonadGen)+import qualified Hedgehog++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)+ => Text+ -> Text+ -> Sem.Sem effs a+throwInterpretError actionName message = do+ errorMsg <-+ Sem.gets $ \ctxt ->+ "\n----------\nACTION\t" <>+ actionName <>+ "\n\nMESSAGE\t" <>+ message <> "\n\nSTATE\t" <> showText ctxt <> "\n----------\n"+ Sem.throw errorMsg++unwrapRight :: Renderer e -> Either e a -> a+unwrapRight _ (Right x) = x+unwrapRight errorRenderer (Left x) = error $ errorRenderer x++assertEqual :: (Eq a, Show a) => Text -> a -> a -> Assertion+assertEqual msg expected actual =+ catch (HUnit.assertEqual "" expected actual) $ \(HUnitFailure maybeSrcLoc errorMsg) ->+ errorWithoutStackTrace $+ "assertEquals FAILURE\n\nmessage: " <>+ msg <>+ "\n\n" <>+ T.pack errorMsg <>+ (case maybeSrcLoc of+ Just srcLoc -> "\n\nat: " <> showText srcLoc+ Nothing -> "")++-- | Will error at runtime if a parse error occurs.+-- | 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++-- 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`.+type MonadGen m = (Hedgehog.MonadGen m, GenBase m ~ Identity)++failSpec :: Text -> Expectation+failSpec = expectationFailure . T.unpack