axel 0.0.8 → 0.0.9
raw patch · 36 files changed
+1278/−458 lines, 36 filesdep +containersdep +ghcid
Dependencies added: containers, ghcid
Files
- app/Main.hs +36/−45
- axel.cabal +12/−2
- resources/autogenerated/macros/AST.hs +11/−1
- resources/macros/MacroDefinitionAndEnvironmentFooter.hs +2/−1
- resources/macros/MacroDefinitionAndEnvironmentHeader.hs +5/−1
- resources/macros/Scaffold.hs +5/−3
- resources/new-project-template/Setup.hs +2/−3
- resources/new-project-template/app/Main.hs +3/−3
- resources/new-project-template/src/Lib.hs +3/−2
- resources/new-project-template/test/Spec.hs +2/−2
- scripts/build.sh +2/−0
- scripts/format.sh +1/−4
- scripts/lint.sh +1/−1
- src/Axel.hs +115/−0
- src/Axel/AST.hs +53/−33
- src/Axel/Denormalize.hs +23/−7
- src/Axel/Eff/Console.hs +6/−13
- src/Axel/Eff/Ghci.hs +28/−0
- src/Axel/Eff/Process.hs +4/−21
- src/Axel/Eff/Resource.hs +4/−11
- src/Axel/Haskell/Converter.hs +502/−0
- src/Axel/Haskell/File.hs +84/−34
- src/Axel/Haskell/Language.hs +4/−3
- src/Axel/Haskell/Macros.hs +29/−0
- src/Axel/Haskell/Project.hs +9/−6
- src/Axel/Haskell/Stack.hs +6/−8
- src/Axel/Macros.hs +185/−146
- src/Axel/Normalize.hs +28/−7
- src/Axel/Parse/AST.hs +11/−1
- src/Axel/Parse/Args.hs +15/−87
- src/Axel/Utils/Lens.hs +6/−0
- test/Axel/Test/ASTGen.hs +21/−11
- test/Axel/Test/Eff/GhciMock.hs +50/−0
- test/Axel/Test/Eff/ProcessMock.hs +1/−1
- test/Axel/Test/File/FileSpec.hs +7/−0
- test/Axel/Test/MockUtils.hs +2/−1
app/Main.hs view
@@ -1,48 +1,39 @@ {-# LANGUAGE DataKinds #-}-+{-# LANGUAGE TypeApplications #-} module Main where- import Prelude hiding (putStrLn)--import Axel.Eff.Console (putStrLn)-import qualified Axel.Eff.Console as Effs (Console)-import qualified Axel.Eff.Console as Console (runEff)-import qualified Axel.Eff.FileSystem as FS (runEff)-import qualified Axel.Eff.FileSystem as Effs (FileSystem)-import qualified Axel.Eff.Process as Proc (runEff)-import qualified Axel.Eff.Process as Effs (Process)-import qualified Axel.Eff.Resource as Res (runEff)-import qualified Axel.Eff.Resource as Effs (Resource)-import Axel.Error (Error)-import qualified Axel.Error as Error (runEff)-import Axel.Haskell.File (transpileFile')-import Axel.Haskell.Project (buildProject, runProject)-import Axel.Haskell.Stack (axelStackageVersion)-import Axel.Parse.Args (Command(File, Project, Version), commandParser)--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 Options.Applicative ((<**>), execParser, helper, info, progDesc)--type AppEffs- = Eff '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource, IO]--runApp :: AppEffs a -> IO a-runApp =- Effs.runM .- Res.runEff . Proc.runEff . FS.runEff . Error.runEff . Console.runEff--app :: Command -> AppEffs ()-app (File filePath) = void $ transpileFile' filePath-app Project = buildProject >> runProject-app Version = putStrLn $ "Axel version " <> axelStackageVersion--main :: IO ()-main = do- modeCommand <-- execParser $- info (commandParser <**> helper) (progDesc "The command to run.")- runApp $ app modeCommand+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.Haskell.Stack(axelStackageVersion)+import Axel.Macros(ModuleInfo)+import Axel.Parse.Args(Command(Convert,File,Project,Version),commandParser)+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 {}+main :: (IO ())+main = do { modeCommand <- execParser $ info (commandParser <**> helper) (progDesc "The command to run."); runApp $ app modeCommand} where {}
axel.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 01937382699276a02f31dac43a069626cd750821b38768ce5e6092998a14e176+-- hash: 1a1b9e269848a5390e4269df0118c7451807f8c073435b803ba49dea56a7fa28 name: axel-version: 0.0.8+version: 0.0.9 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@@ -47,15 +47,19 @@ library exposed-modules:+ Axel Axel.AST Axel.Denormalize Axel.Eff.Console Axel.Eff.FileSystem+ Axel.Eff.Ghci Axel.Eff.Process Axel.Eff.Resource Axel.Error+ Axel.Haskell.Converter Axel.Haskell.File Axel.Haskell.Language+ Axel.Haskell.Macros Axel.Haskell.Prettify Axel.Haskell.Project Axel.Haskell.Stack@@ -67,6 +71,7 @@ Axel.Utils.Debug Axel.Utils.Display Axel.Utils.Function+ Axel.Utils.Lens Axel.Utils.List Axel.Utils.Recursion Axel.Utils.String@@ -78,9 +83,11 @@ 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@@ -107,6 +114,7 @@ build-depends: axel , base >=4.12 && <4.13+ , containers >=0.6 , freer-simple >=1.2.0.0 , optparse-applicative >=0.14.2 default-language: Haskell2010@@ -121,6 +129,7 @@ Axel.Test.Eff.ConsoleSpec Axel.Test.Eff.FileSystemMock Axel.Test.Eff.FileSystemSpec+ Axel.Test.Eff.GhciMock Axel.Test.Eff.ProcessMock Axel.Test.Eff.ResourceMock Axel.Test.Eff.ResourceSpec@@ -138,6 +147,7 @@ axel , base >=4.12 && <4.13 , bytestring+ , containers , filepath , freer-simple >=1.2.0.0 , hedgehog
resources/autogenerated/macros/AST.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} @@ -7,6 +8,7 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef) import Data.Semigroup ((<>))+import Data.Typeable (Typeable) import System.IO.Unsafe (unsafePerformIO) @@ -19,7 +21,7 @@ | LiteralString String | SExpression [Expression] | Symbol String- deriving (Eq, Show)+ deriving (Eq, Show, Typeable) -- ****************************** -- Internal utilities@@ -61,3 +63,11 @@ 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)
@@ -1,1 +1,2 @@-%%%MACRO_NAME%%% :: [AST.Expression] -> IO [AST.Expression]+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 view
@@ -1,1 +1,5 @@-module MacroDefinitionAndEnvironment where+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 view
@@ -1,10 +1,12 @@-module Scaffold where+module AutogeneratedAxelScaffold where +import qualified AutogeneratedAxelMacroDefinitionAndEnvironment import Axel.Parse.AST-import qualified MacroDefinitionAndEnvironment as MacroDefinitionAndEnvironment +import Unsafe.Coerce (unsafeCoerce)+ main :: IO () main = do result <-- MacroDefinitionAndEnvironment.%%%MACRO_NAME%%% %%%ARGUMENTS%%%+ AutogeneratedAxelMacroDefinitionAndEnvironment.main_AXEL_AUTOGENERATED_FUNCTION_DEFINITION (map unsafeCoerce %%%ARGUMENTS%%%) putStrLn $ unlines $ map toAxel result
resources/new-project-template/Setup.hs view
@@ -1,4 +1,3 @@ import Distribution.Simple (defaultMain)--main :: (IO ())-main = defaultMain+main IO () = (() defaultMain)+ where
resources/new-project-template/app/Main.hs view
@@ -1,4 +1,4 @@+module Main where import Lib--main :: (IO ())-main = someFunc+main IO () = (() someFunc)+ where
resources/new-project-template/src/Lib.hs view
@@ -1,2 +1,3 @@-someFunc :: (IO ())-someFunc = (putStrLn "someFunc")+module Lib where+someFunc IO () = (() (putStrLn "someFunc"))+ where
resources/new-project-template/test/Spec.hs view
@@ -1,2 +1,2 @@-main :: (IO ())-main = (putStrLn "Test suite not yet implemented")+main IO () = (() (putStrLn "Test suite not yet implemented"))+ where
scripts/build.sh view
@@ -7,3 +7,5 @@ echo "Macro header copied!" stack build --fast+stack exec axel-exe -- project+stack build --fast
scripts/format.sh view
@@ -1,4 +1,1 @@-#!/bin/zsh-for f in {app,src,test}/**/*.hs; do- hindent "$f"-done+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/lint.sh view
@@ -1,1 +1,1 @@-hlint app src test+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'
+ src/Axel.hs view
@@ -0,0 +1,115 @@+module Axel where+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)))
src/Axel/AST.hs view
@@ -10,6 +10,7 @@ module Axel.AST where import Axel.Haskell.Language (isOperator)+import Axel.Haskell.Macros (hygenisizeMacroName) import Axel.Utils.Display ( Bracket(CurlyBraces, DoubleQuotes, Parentheses, SingleQuotes, SquareBrackets)@@ -19,13 +20,12 @@ , renderPragma , surround )-import Axel.Utils.Recursion- ( Recursive(bottomUpFmap, bottomUpTraverse, topDownFmap)- )+import Axel.Utils.Recursion (Recursive(bottomUpFmap, bottomUpTraverse)) import Control.Arrow ((***)) import Control.Lens.Operators ((%~), (^.))-import Control.Lens.TH (makeFieldsNoPrefix)+import Control.Lens.TH (makeFieldsNoPrefix, makePrisms)+ import Data.Function ((&)) import Data.Semigroup ((<>)) @@ -44,6 +44,12 @@ , _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)@@ -115,6 +121,11 @@ { _functionDefinition :: FunctionDefinition } deriving (Eq, Show) +data MacroImport = MacroImport+ { _moduleName :: Identifier+ , _imports :: [Identifier]+ } deriving (Eq, Show)+ newtype Pragma = Pragma { _pragmaSpecification :: String } deriving (Eq, Show)@@ -164,6 +175,7 @@ | EEmptySExpression | EFunctionApplication FunctionApplication | EIdentifier Identifier+ | EIfBlock IfBlock | ELambda Lambda | ELetBlock LetBlock | ELiteral Literal@@ -181,6 +193,7 @@ 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@@ -204,6 +217,7 @@ = SDataDeclaration DataDeclaration | SFunctionDefinition FunctionDefinition | SMacroDefinition MacroDefinition+ | SMacroImport MacroImport | SModuleDeclaration Identifier | SNewtypeDeclaration NewtypeDeclaration | SPragma Pragma@@ -224,6 +238,7 @@ 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@@ -236,6 +251,8 @@ toHaskell (STypeSynonym x) = toHaskell x toHaskell (SUnrestrictedImport x) = "import " <> x +makePrisms ''Statement+ type Program = [Statement] makeFieldsNoPrefix ''CaseBlock@@ -250,8 +267,12 @@ makeFieldsNoPrefix ''LetBlock +makeFieldsNoPrefix ''IfBlock+ makeFieldsNoPrefix ''MacroDefinition +makeFieldsNoPrefix ''MacroImport+ makeFieldsNoPrefix ''NewtypeDeclaration makeFieldsNoPrefix ''Pragma@@ -322,6 +343,14 @@ where removeSurroundingParentheses = tail . init +instance ToHaskell IfBlock where+ toHaskell :: IfBlock -> String+ toHaskell ifBlock =+ "if " <> toHaskell (ifBlock ^. cond) <> " then " <>+ toHaskell (ifBlock ^. ifTrue) <>+ " else " <>+ toHaskell (ifBlock ^. ifFalse)+ instance ToHaskell NewtypeDeclaration where toHaskell :: NewtypeDeclaration -> String toHaskell newtypeDeclaration =@@ -356,10 +385,20 @@ toHaskell :: MacroDefinition -> String toHaskell macroDefinition = toHaskell (macroDefinition ^. functionDefinition) +instance ToHaskell MacroImport where+ toHaskell :: MacroImport -> String+ toHaskell macroImport =+ toHaskell $+ RestrictedImport+ (macroImport ^. moduleName)+ (ImportOnly $+ map (ImportItem . hygenisizeMacroName) $ macroImport ^. imports)+ instance ToHaskell QualifiedImport where toHaskell :: QualifiedImport -> String toHaskell qualifiedImport =- "import " <> qualifiedImport ^. moduleName <> " as " <> qualifiedImport ^.+ "import qualified " <> qualifiedImport ^. moduleName <> " as " <>+ qualifiedImport ^. alias <> toHaskell (qualifiedImport ^. imports) @@ -430,34 +469,10 @@ functionApplication & function %~ bottomUpFmap f & arguments %~ map (bottomUpFmap f) EIdentifier _ -> x- 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- topDownFmap :: (Expression -> Expression) -> Expression -> Expression- topDownFmap f x =- case f 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@@ -491,6 +506,11 @@ 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) <*>
src/Axel/Denormalize.hs view
@@ -2,22 +2,23 @@ import Axel.AST ( Expression(ECaseBlock, EEmptySExpression, EFunctionApplication,- EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression,- ERecordDefinition, ERecordType)+ EIdentifier, EIfBlock, ELambda, ELetBlock, ELiteral,+ ERawExpression, ERecordDefinition, ERecordType) , Import(ImportItem, ImportType) , ImportSpecification(ImportAll, ImportOnly) , Literal(LChar, LInt, LString) , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,- SModuleDeclaration, SNewtypeDeclaration, SPragma, SQualifiedImport,- SRawStatement, SRestrictedImport, STopLevel, STypeSignature,- STypeSynonym, STypeclassDefinition, STypeclassInstance,- SUnrestrictedImport)+ SMacroImport, SModuleDeclaration, SNewtypeDeclaration, SPragma,+ SQualifiedImport, SRawStatement, SRestrictedImport, STopLevel,+ STypeSignature, STypeSynonym, STypeclassDefinition,+ STypeclassInstance, SUnrestrictedImport) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor) , alias , arguments , bindings , body+ , cond , constraints , constructor , constructors@@ -27,6 +28,8 @@ , fields , function , functionDefinition+ , ifFalse+ , ifTrue , imports , instanceName , matches@@ -60,6 +63,13 @@ Parse.SExpression $ denormalizeExpression (functionApplication ^. function) : map denormalizeExpression (functionApplication ^. arguments) denormalizeExpression (EIdentifier x) = Parse.Symbol x+denormalizeExpression (EIfBlock ifBlock) =+ Parse.SExpression+ [ Parse.Symbol "if"+ , denormalizeExpression (ifBlock ^. cond)+ , denormalizeExpression (ifBlock ^. ifTrue)+ , denormalizeExpression (ifBlock ^. ifFalse)+ ] denormalizeExpression (ELambda lambda) = let denormalizedArguments = Parse.SExpression $ map denormalizeExpression (lambda ^. arguments)@@ -130,7 +140,7 @@ denormalizeExpression (fnDef ^. body) : map (denormalizeStatement . SFunctionDefinition) (fnDef ^. whereBindings) denormalizeStatement (SMacroDefinition macroDef) =- Parse.SExpression $ Parse.Symbol "macro" :+ Parse.SExpression $ Parse.Symbol "=macro" : Parse.Symbol (macroDef ^. functionDefinition . name) : Parse.SExpression (map denormalizeExpression (macroDef ^. functionDefinition . arguments)) :@@ -138,6 +148,12 @@ 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] denormalizeStatement (SNewtypeDeclaration newtypeDeclaration) =
src/Axel/Eff/Console.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} module Axel.Eff.Console where@@ -10,26 +11,18 @@ import Prelude hiding (putStr) import qualified Prelude -import Control.Monad.Freer- ( type (~>)- , Eff- , LastMember- , Member- , interpretM- , send- )+import Control.Monad.Freer (type (~>), Eff, LastMember, Member, interpretM)+import Control.Monad.Freer.TH (makeEffect) data Console r where PutStr :: String -> Console () -putStr :: (Member Console effs) => String -> Eff effs ()-putStr = send . PutStr+makeEffect ''Console runEff :: (LastMember IO effs) => Eff (Console ': effs) ~> Eff effs runEff =- interpretM- (\case- PutStr str -> Prelude.putStr str)+ interpretM $ \case+ PutStr str -> Prelude.putStr str putStrLn :: (Member Console effs) => String -> Eff effs () putStrLn str = putStr (str <> "\n")
+ src/Axel/Eff/Ghci.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module Axel.Eff.Ghci where++import Control.Monad.Freer (type (~>), Eff, LastMember, interpretM)+import Control.Monad.Freer.TH (makeEffect)++import Language.Haskell.Ghcid (startGhci, stopGhci)+import qualified Language.Haskell.Ghcid as Ghci (Ghci, exec)++data Ghci r where+ Exec :: Ghci.Ghci -> String -> Ghci [String]+ Start :: Ghci Ghci.Ghci+ Stop :: Ghci.Ghci -> Ghci ()++makeEffect ''Ghci++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
src/Axel/Eff/Process.hs view
@@ -13,14 +13,8 @@ module Axel.Eff.Process where -import Control.Monad.Freer- ( type (~>)- , Eff- , LastMember- , Member- , interpretM- , send- )+import Control.Monad.Freer (type (~>), Eff, LastMember, Member, interpretM)+import Control.Monad.Freer.TH (makeEffect) import Data.Singletons (Sing, SingI, sing) import Data.Singletons.TH (singletons)@@ -32,7 +26,7 @@ $(singletons [d|-+ data StreamSpecification = CreateStreams | InheritStreams |])@@ -61,18 +55,7 @@ :: FilePath -> [String] -> String -> Process (ExitCode, String, String) RunProcessInheritingStreams :: FilePath -> [String] -> Process ExitCode -getArgs :: (Member Process effs) => Eff effs [String]-getArgs = send GetArgs--runProcessCreatingStreams ::- (Member Process effs) => ProcessRunnerPrimitive 'CreateStreams (Eff effs)-runProcessCreatingStreams cmd args stdin =- send $ RunProcessCreatingStreams cmd args stdin--runProcessInheritingStreams ::- (Member Process effs) => ProcessRunnerPrimitive 'InheritStreams (Eff effs)-runProcessInheritingStreams cmd args =- send $ RunProcessInheritingStreams cmd args+makeEffect ''Process runEff :: (LastMember IO effs) => Eff (Process ': effs) ~> Eff effs runEff =
src/Axel/Eff/Resource.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} module Axel.Eff.Resource where@@ -9,15 +10,8 @@ import Axel.Eff.FileSystem as FS (FileSystem, readFile) import Control.Monad ((>=>))-import Control.Monad.Freer- ( type (~>)- , Eff- , LastMember- , Member- , Members- , interpretM- , send- )+import Control.Monad.Freer (type (~>), Eff, LastMember, Members, interpretM)+import Control.Monad.Freer.TH (makeEffect) import Paths_axel (getDataFileName) @@ -29,8 +23,7 @@ data Resource a where GetResourcePath :: ResourceId -> Resource FilePath -getResourcePath :: (Member Resource effs) => ResourceId -> Eff effs FilePath-getResourcePath = send . GetResourcePath+makeEffect ''Resource runEff :: (LastMember IO effs) => Eff (Resource ': effs) ~> Eff effs runEff =
+ src/Axel/Haskell/Converter.hs view
@@ -0,0 +1,502 @@+{-# 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/File.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -10,39 +9,46 @@ import Prelude hiding (putStr, putStrLn) -import Axel.AST (ToHaskell(toHaskell))-import Axel.Eff.Console (putStrLn)+import Axel.AST (Statement(SModuleDeclaration), ToHaskell(toHaskell))+import Axel.Eff.Console (putStr, putStrLn) import qualified Axel.Eff.Console as Effs (Console) import qualified Axel.Eff.FileSystem as Effs (FileSystem)-import qualified Axel.Eff.FileSystem as FS- ( readFile- , withTemporaryDirectory- , writeFile- )+import qualified Axel.Eff.FileSystem as FS (readFile, removeFile, writeFile)+import qualified Axel.Eff.Ghci as Effs (Ghci) import Axel.Eff.Process (StreamSpecification(InheritStreams)) import qualified Axel.Eff.Process as Effs (Process) import Axel.Eff.Resource (readResource) import qualified Axel.Eff.Resource as Effs (Resource) import qualified Axel.Eff.Resource as Res (astDefinition) import Axel.Error (Error)+import Axel.Haskell.Converter (convertFile) import Axel.Haskell.Prettify (prettifyHaskell) import Axel.Haskell.Stack (interpretFile)-import Axel.Macros (exhaustivelyExpandMacros)+import Axel.Macros (ModuleInfo, exhaustivelyExpandMacros) import Axel.Normalize (normalizeStatement)-import Axel.Parse (Expression(Symbol), parseSource)+import Axel.Parse+ ( Expression(Symbol)+ , parseSource+ , programToTopLevelExpressions+ ) import Axel.Utils.Recursion (Recursive(bottomUpFmap)) -import Control.Lens.Operators ((.~))-import Control.Monad (void)-import Control.Monad.Freer (Eff, Members)+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 Data.Maybe (fromMaybe)+import qualified Data.Map as Map (adjust, fromList, lookup)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid (Alt(Alt)) import Data.Semigroup ((<>)) import qualified Data.Text as T (isSuffixOf, pack) -import System.FilePath ((</>), stripExtension, takeFileName)-import System.FilePath.Lens (directory)+import System.FilePath (stripExtension, takeFileName) convertList :: Expression -> Expression convertList =@@ -57,42 +63,87 @@ Symbol "unit" -> Symbol "()" x -> x +readModuleInfo ::+ (Members '[ Effs.Error Error, Effs.FileSystem] effs)+ => [FilePath]+ -> Eff effs ModuleInfo+readModuleInfo axelFiles = do+ modules <-+ forM axelFiles $ \filePath -> do+ source <- FS.readFile filePath+ exprs <- programToTopLevelExpressions <$> parseSource source+ Alt moduleDecl <-+ mconcat . map Alt <$>+ mapM+ (\expr ->+ runError @Error (normalizeStatement expr) <&> \case+ Right (SModuleDeclaration moduleId) ->+ Just (filePath, (moduleId, False))+ _ -> Nothing)+ exprs+ pure moduleDecl+ pure $ Map.fromList $ catMaybes modules+ transpileSource ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)+ (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 . convertList . convertUnit >>=+ (parseSource source >>=+ exhaustivelyExpandMacros transpileFile' . convertList . convertUnit >>= normalizeStatement) -axelPathToHaskellPath :: FilePath -> FilePath-axelPathToHaskellPath axelPath =+convertExtension :: String -> String -> FilePath -> FilePath+convertExtension oldExt newExt axelPath = let basePath =- if ".axel" `T.isSuffixOf` T.pack axelPath- then fromMaybe axelPath $ stripExtension ".axel" axelPath+ if T.pack newExt `T.isSuffixOf` T.pack axelPath+ then fromMaybe axelPath $ stripExtension newExt axelPath else axelPath- in basePath <> ".hs"+ in basePath <> oldExt +axelPathToHaskellPath :: FilePath -> FilePath+axelPathToHaskellPath = convertExtension ".hs" ".axel"++haskellPathToAxelPath :: FilePath -> FilePath+haskellPathToAxelPath = convertExtension ".axel" ".hs"++-- | Convert a file in place.+convertFile' ::+ (LastMember IO effs, Members '[ Effs.Console, Effs.FileSystem] effs)+ => FilePath+ -> Eff effs FilePath+convertFile' path = do+ let newPath = haskellPathToAxelPath path+ void $ convertFile path newPath+ pure newPath+ transpileFile ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)+ (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource, Effs.State ModuleInfo] effs) => FilePath -> FilePath -> Eff effs () transpileFile path newPath = do+ putStr $ "Transpiling " <> path <> "..." fileContents <- FS.readFile path newContents <- transpileSource fileContents- putStrLn "Writing file..."+ putStrLn $ " Transpiled to " <> newPath <> "!" FS.writeFile newPath newContents+ modify @ModuleInfo $ Map.adjust (_2 %~ not) path -- | Transpile a file in place. transpileFile' ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)+ (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource, Effs.State ModuleInfo] effs) => FilePath -> Eff effs FilePath transpileFile' path = do+ moduleInfo <- gets @ModuleInfo $ Map.lookup path+ let alreadyCompiled =+ case moduleInfo of+ Just (_, isCompiled) -> isCompiled+ Nothing -> False let newPath = axelPathToHaskellPath path- transpileFile path newPath+ unless alreadyCompiled $ transpileFile path newPath pure newPath evalFile ::@@ -101,10 +152,9 @@ -> Eff effs () evalFile path = do putStrLn ("Building " <> takeFileName path <> "...")- FS.withTemporaryDirectory $ \tempDirectoryPath -> do- let astDefinitionPath = tempDirectoryPath </> "Axel.hs"- readResource Res.astDefinition >>= FS.writeFile astDefinitionPath- let newPath = directory .~ tempDirectoryPath $ axelPathToHaskellPath path- transpileFile path newPath- putStrLn ("Running " <> takeFileName path <> "...")- void $ interpretFile @'InheritStreams newPath+ 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
src/Axel/Haskell/Language.hs view
@@ -4,7 +4,8 @@ -- https://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators isOperator :: String -> Bool-isOperator = all $ \x -> isSymbol x || x `elem` map fst haskellOperatorSymbols+isOperator =+ all $ \x -> isSymbol x || x `elem` map fst haskellOperatorSymbols || x == ',' haskellOperatorSymbols :: [(Char, String)] haskellOperatorSymbols =@@ -27,12 +28,12 @@ , ('-', "axelSymbolDash") , ('|', "axelSymbolPipe") , ('~', "axelSymbolTilde")+ , ('.', "axelSymbolDot") ] haskellSyntaxSymbols :: [(Char, String)] haskellSyntaxSymbols =- [ ('.', "axelSymbolDot")- , (',', "axelSymbolComma")+ [ (',', "axelSymbolComma") , (';', "axelSymbolSemicolon") , ('[', "axelSymbolLeftBracket") , (']', "axelSymbolRightBracket")
+ src/Axel/Haskell/Macros.hs view
@@ -0,0 +1,29 @@+{-# 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 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)
src/Axel/Haskell/Project.hs view
@@ -12,11 +12,12 @@ , removeFile ) import qualified Axel.Eff.FileSystem as Effs (FileSystem)+import qualified Axel.Eff.Ghci as Effs (Ghci) import qualified Axel.Eff.Process as Effs (Process) import Axel.Eff.Resource (getResourcePath, newProjectTemplate) import qualified Axel.Eff.Resource as Effs (Resource) import Axel.Error (Error)-import Axel.Haskell.File (transpileFile')+import Axel.Haskell.File (readModuleInfo, transpileFile') import Axel.Haskell.Stack ( addStackDependency , axelStackageId@@ -28,6 +29,7 @@ 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)@@ -52,20 +54,21 @@ mapM_ copyAxel ["Setup", "app" </> "Main", "src" </> "Lib", "test" </> "Spec"] transpileProject ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)+ (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource] effs) => Eff effs [FilePath] transpileProject = do- files <- getDirectoryContentsRec "."+ files <- concat <$> mapM getDirectoryContentsRec ["app", "src", "test"] let axelFiles = filter (\filePath -> ".axel" `T.isSuffixOf` T.pack filePath) files- mapM transpileFile' axelFiles+ moduleInfo <- readModuleInfo axelFiles+ evalState moduleInfo $ mapM transpileFile' axelFiles buildProject ::- (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)+ (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource] effs) => Eff effs () buildProject = do projectPath <- getCurrentDirectory- void $ transpileProject+ void transpileProject buildStackProject projectPath runProject ::
src/Axel/Haskell/Stack.hs view
@@ -114,9 +114,7 @@ stderr) createStackProject ::- (Member Effs.FileSystem effs, Member Effs.Process effs)- => String- -> Eff effs ()+ (Members '[ Effs.FileSystem, Effs.Process] effs) => String -> Eff effs () createStackProject projectName = do void $ runProcess @'CreateStreams "stack" ["new", projectName, "new-template"] ""@@ -145,7 +143,7 @@ [] setStackageResolver ::- (Member Effs.FileSystem effs, Member Effs.Process effs)+ (Members '[ Effs.FileSystem, Effs.Process] effs) => ProjectPath -> StackageResolver -> Eff effs ()@@ -162,13 +160,13 @@ => FilePath -> ProcessRunner streamSpec (Eff effs) compileFile filePath =- let args = [["ghc"], includeAxelArguments, ["--", filePath]]- in runProcess @streamSpec @effs "stack" (concat args)+ let args = concat [["ghc"], includeAxelArguments, ["--", filePath]]+ in runProcess @streamSpec @effs "stack" args interpretFile :: forall (streamSpec :: StreamSpecification) effs. (Member Effs.Process effs) => FilePath -> ProcessRunner streamSpec (Eff effs) interpretFile filePath =- let args = [["runghc"], includeAxelArguments, ["--", filePath]]- in runProcess @streamSpec @effs "stack" (concat args)+ let args = concat [["runghc"], includeAxelArguments, ["--", filePath]]+ in runProcess @streamSpec @effs "stack" args
src/Axel/Macros.hs view
@@ -2,33 +2,36 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Axel.Macros where +import Prelude hiding (putStrLn)+ import Axel.AST- ( MacroDefinition+ ( Expression(EFunctionApplication, EIdentifier)+ , FunctionApplication(FunctionApplication)+ , Identifier+ , MacroDefinition , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,- SModuleDeclaration, SNewtypeDeclaration, SPragma, SQualifiedImport,- SRawStatement, SRestrictedImport, STopLevel, STypeSignature,- STypeSynonym, STypeclassDefinition, STypeclassInstance,- SUnrestrictedImport)+ SMacroImport, SModuleDeclaration, SNewtypeDeclaration, SPragma,+ SQualifiedImport, SRawStatement, SRestrictedImport, STopLevel,+ STypeSignature, STypeSynonym, STypeclassDefinition,+ STypeclassInstance, SUnrestrictedImport) , ToHaskell(toHaskell)+ , TypeSignature(TypeSignature) , functionDefinition+ , imports+ , moduleName , name ) import Axel.Denormalize (denormalizeStatement) import qualified Axel.Eff.FileSystem as Effs (FileSystem)-import qualified Axel.Eff.FileSystem as FS- ( createDirectoryIfMissing- , withCurrentDirectory- , withTemporaryDirectory- , writeFile- )-import Axel.Eff.Process (StreamSpecification(CreateStreams))+import qualified Axel.Eff.FileSystem as FS (removeFile, writeFile)+import qualified Axel.Eff.Ghci as Effs (Ghci)+import qualified Axel.Eff.Ghci as Ghci (exec, start, stop) import qualified Axel.Eff.Process as Effs (Process) import Axel.Eff.Resource (readResource) import qualified Axel.Eff.Resource as Effs (Resource)@@ -38,21 +41,14 @@ , macroDefinitionAndEnvironmentHeader , macroScaffold )-import Axel.Error (Error(MacroError))-import Axel.Haskell.Language- ( haskellOperatorSymbols- , haskellSyntaxSymbols- , isOperator- )+import Axel.Error (Error)+import Axel.Haskell.Macros (hygenisizeMacroName) import Axel.Haskell.Prettify (prettifyHaskell)-import Axel.Haskell.Stack (interpretFile) import Axel.Normalize (normalizeStatement) import qualified Axel.Parse as Parse- ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,- Symbol)+ ( Expression(SExpression, Symbol) , parseMultiple , programToTopLevelExpressions- , syntaxSymbols , topLevelExpressionsToProgram ) import Axel.Utils.Display (Delimiter(Newlines), delimit)@@ -63,108 +59,96 @@ import Control.Lens.Cons (snoc) import Control.Lens.Operators ((%~), (^.)) import Control.Lens.Tuple (_1, _2)-import Control.Monad (foldM)+import Control.Monad (foldM, unless, void) import Control.Monad.Freer (Eff, Members)-import Control.Monad.Freer.Error (throwError) 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 Data.Function ((&))-import Data.List (foldl')-import Data.List.NonEmpty (NonEmpty, nonEmpty)-import qualified Data.List.NonEmpty as NE (head, map, toList)+import Data.List (nub)+import Data.Map (Map)+import qualified Data.Map as Map (filter, toList)+import Data.Maybe (listToMaybe, mapMaybe) import Data.Semigroup ((<>))-import qualified Data.Text as T (isSuffixOf, pack, replace, singleton, unpack) -import System.Exit (ExitCode(ExitFailure))-import System.FilePath ((</>))+import qualified Language.Haskell.Ghcid as Ghci (Ghci) -hygenisizeMacroName :: String -> String-hygenisizeMacroName oldName =- let suffix =- if isOperator oldName- then "%%%%%%%%%%"- else "_AXEL_AUTOGENERATED_MACRO_DEFINITION"- suffixedName =- if T.pack suffix `T.isSuffixOf` 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, _) -> sym `notElem` Parse.syntaxSymbols)- (haskellSyntaxSymbols <> haskellOperatorSymbols))+import System.FilePath ((<.>)) +type ModuleInfo = Map Identifier (FilePath, Bool)+ hygenisizeMacroDefinition :: MacroDefinition -> MacroDefinition hygenisizeMacroDefinition macroDef = macroDef & functionDefinition . name %~ hygenisizeMacroName generateMacroProgram :: (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Resource] effs)- => NonEmpty MacroDefinition+ => Identifier+ -> [MacroDefinition] -> [Statement] -> [Parse.Expression] -> Eff effs (String, String, String)-generateMacroProgram macroDefs env applicationArgs = do+generateMacroProgram oldMacroName macroDefs env args = do astDef <- readResource Res.astDefinition- scaffold <- getScaffold- macroDefAndEnv <- (<>) <$> getMacroDefAndEnvHeader <*> getMacroDefAndEnvFooter+ 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- oldMacroName = NE.head macroDefs ^. functionDefinition . name+ insertArgs =+ let argsPlaceholder = "%%%ARGUMENTS%%%"+ in replace argsPlaceholder (show args) newMacroName = hygenisizeMacroName oldMacroName- getMacroDefAndEnvHeader =- insertDefName <$> readResource Res.macroDefinitionAndEnvironmentHeader- getMacroDefAndEnvFooter = do- let hygenicMacroDefs = NE.map hygenisizeMacroDefinition macroDefs- let source =- prettifyHaskell $ delimit Newlines $- map- toHaskell- (env <> NE.toList (NE.map SMacroDefinition hygenicMacroDefs))- footer <-- insertDefName <$> readResource Res.macroDefinitionAndEnvironmentFooter- pure $ unlines [source, footer]- getScaffold =- let insertApplicationArgs =- let applicationArgsPlaceholder = "%%%ARGUMENTS%%%"- in replace applicationArgsPlaceholder (show applicationArgs)- in prettifyHaskell . insertApplicationArgs . insertDefName <$>- readResource Res.macroScaffold+ macroDefAndEnvBody =+ let hygenicMacroDefs = map hygenisizeMacroDefinition macroDefs+ in prettifyHaskell $ delimit Newlines $+ map toHaskell (env <> map SMacroDefinition hygenicMacroDefs) expansionPass ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)- => Parse.Expression+ (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 programExpr =+expansionPass ghci expandFile programExpr = Parse.topLevelExpressionsToProgram . map denormalizeStatement <$>- expandMacros (Parse.programToTopLevelExpressions programExpr)--programToTopLevelExpressions :: Parse.Expression -> [Parse.Expression]-programToTopLevelExpressions (Parse.SExpression (Parse.Symbol "begin":stmts)) =- stmts-programToTopLevelExpressions _ =- error "programToTopLevelExpressions must be passed a top-level program!"--topLevelExpressionsToProgram :: [Parse.Expression] -> Parse.Expression-topLevelExpressionsToProgram stmts =- Parse.SExpression (Parse.Symbol "begin" : stmts)+ expandMacros ghci expandFile (Parse.programToTopLevelExpressions programExpr) exhaustivelyExpandMacros ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)- => Parse.Expression+ (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 = exhaustM expansionPass+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 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@@ -177,11 +161,45 @@ isStatementNonconflicting (STypeSynonym _) = True isStatementNonconflicting (SUnrestrictedImport _) = True +isMacroImported :: Identifier -> [Statement] -> Bool+isMacroImported macroName =+ any+ (\case+ SMacroImport macroImport -> macroName `elem` macroImport ^. imports+ _ -> False)++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"]+ ]+ ]))+ macroNames+ where+ macroNames = nub $ map (^. functionDefinition . name) macroDefs+ expandMacros ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)- => [Parse.Expression]+ (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 topLevelExprs = do+expandMacros ghci expandFile topLevelExprs = do (stmts, macroDefs) <- foldM (\acc@(stmts, macroDefs) expr -> do@@ -189,10 +207,25 @@ foldM (\acc' expandedExpr -> do stmt <- normalizeStatement expandedExpr- pure $ acc' &- case stmt of- SMacroDefinition macroDef -> _2 %~ flip snoc macroDef- _ -> _1 %~ flip snoc stmt)+ 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) ([], [])@@ -210,15 +243,25 @@ foldM (\acc x -> case x of- Parse.SExpression (function:args) ->- case lookupMacroDefinitions function allMacroDefs of- Just macroDefs ->- (acc <>) <$>- expandMacroApplication- macroDefs- (filter isStatementNonconflicting stmts)- args- Nothing -> pure $ snoc acc x+ 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@@ -227,58 +270,54 @@ pure $ Parse.programToTopLevelExpressions expandedExpr expandMacroApplication ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process, Effs.Resource] effs)- => NonEmpty MacroDefinition+ (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process, Effs.Resource] effs)+ => Ghci.Ghci+ -> Identifier+ -> [MacroDefinition] -> [Statement] -> [Parse.Expression] -> Eff effs [Parse.Expression]-expandMacroApplication macroDefs auxEnv args = do- macroProgram <- generateMacroProgram macroDefs auxEnv args- newSource <- uncurry3 evalMacro macroProgram+expandMacroApplication ghci macroName macroDefs auxEnv args = do+ macroProgram <- generateMacroProgram macroName macroDefs auxEnv args+ newSource <- uncurry3 (evalMacro ghci) macroProgram Parse.parseMultiple newSource -lookupMacroDefinitions ::- Parse.Expression -> [MacroDefinition] -> Maybe (NonEmpty MacroDefinition)-lookupMacroDefinitions identifierExpr =- nonEmpty . filter (`isMacroBeingCalled` identifierExpr)--isMacroBeingCalled :: MacroDefinition -> Parse.Expression -> Bool-isMacroBeingCalled macroDef identifierExpr =- case identifierExpr of- Parse.LiteralChar _ -> False- Parse.LiteralInt _ -> False- Parse.LiteralString _ -> False- Parse.SExpression _ -> False- Parse.Symbol identifier ->- macroDef ^. functionDefinition . name == identifier+lookupMacroDefinitions :: Identifier -> [MacroDefinition] -> [MacroDefinition]+lookupMacroDefinitions identifier =+ filter (\macroDef -> macroDef ^. functionDefinition . name == identifier) isMacroDefinitionStatement :: Statement -> Bool isMacroDefinitionStatement (SMacroDefinition _) = True isMacroDefinitionStatement _ = False evalMacro ::- (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Process] effs)- => String+ forall effs.+ (Members '[ Effs.Error Error, Effs.FileSystem, Effs.Ghci, Effs.Process] effs)+ => Ghci.Ghci -> String -> String+ -> String -> Eff effs String-evalMacro astDefinition scaffold macroDefinitionAndEnvironment =- FS.withTemporaryDirectory $ \directoryName ->- FS.withCurrentDirectory directoryName $ do- let astDirectoryPath = "Axel" </> "Parse"- let macroDefinitionAndEnvironmentFileName =- "MacroDefinitionAndEnvironment.hs"- let scaffoldFileName = "Scaffold.hs"- FS.createDirectoryIfMissing True astDirectoryPath- FS.writeFile (astDirectoryPath </> "AST.hs") astDefinition- FS.writeFile- macroDefinitionAndEnvironmentFileName- macroDefinitionAndEnvironment- FS.writeFile scaffoldFileName scaffold- interpretFile @'CreateStreams scaffoldFileName "" >>= \case- (ExitFailure _, _, stderr) ->- throwError $- MacroError- ("Temporary directory: " <> directoryName <> "\n\n" <> "Error:\n" <>- stderr)- (_, stdout, _) -> pure stdout+evalMacro ghci astDefinition scaffold macroDefinitionAndEnvironment = do+ let macroDefinitionAndEnvironmentFileName =+ "AutogeneratedAxelMacroDefinitionAndEnvironment.hs"+ let scaffoldModuleName = "AutogeneratedAxelScaffold"+ let scaffoldFileName = scaffoldModuleName <.> "hs"+ let astDefinitionFileName = "AutogeneratedAxelASTDefinition.hs"+ 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
src/Axel/Normalize.hs view
@@ -8,17 +8,19 @@ ( CaseBlock(CaseBlock) , DataDeclaration(DataDeclaration) , Expression(ECaseBlock, EEmptySExpression, EFunctionApplication,- EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression,- ERecordDefinition, ERecordType)+ EIdentifier, EIfBlock, ELambda, ELetBlock, ELiteral,+ ERawExpression, ERecordDefinition, ERecordType) , FunctionApplication(FunctionApplication) , FunctionDefinition(FunctionDefinition) , Identifier+ , IfBlock(IfBlock) , Import(ImportItem, ImportType) , ImportSpecification(ImportAll, ImportOnly) , Lambda(Lambda) , LetBlock(LetBlock) , Literal(LChar, LInt, LString) , MacroDefinition(MacroDefinition)+ , MacroImport(MacroImport) , NewtypeDeclaration(NewtypeDeclaration) , Pragma(Pragma) , QualifiedImport(QualifiedImport)@@ -26,10 +28,10 @@ , RecordType(RecordType) , RestrictedImport(RestrictedImport) , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,- SModuleDeclaration, SNewtypeDeclaration, SPragma, SQualifiedImport,- SRawStatement, SRestrictedImport, STopLevel, STypeSignature,- STypeSynonym, STypeclassDefinition, STypeclassInstance,- SUnrestrictedImport)+ SMacroImport, SModuleDeclaration, SNewtypeDeclaration, SPragma,+ SQualifiedImport, SRawStatement, SRestrictedImport, STopLevel,+ STypeSignature, STypeSynonym, STypeclassDefinition,+ STypeclassInstance, SUnrestrictedImport) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor) , TypeSignature(TypeSignature)@@ -69,6 +71,10 @@ let normalizedArguments = traverse normalizeExpression args in ELambda <$> (Lambda <$> normalizedArguments <*> normalizeExpression body)+ [Parse.Symbol "if", cond, ifTrue, ifFalse] ->+ EIfBlock <$>+ (IfBlock <$> normalizeExpression cond <*> normalizeExpression ifTrue <*>+ normalizeExpression ifFalse) [Parse.Symbol "let", Parse.SExpression bindings, body] -> let normalizedBindings = traverse@@ -213,6 +219,9 @@ [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] -> SQualifiedImport <$> (QualifiedImport moduleName alias <$> normalizeImportSpec expr importSpec)@@ -232,7 +241,7 @@ normalizedDefs) [Parse.Symbol "pragma", Parse.LiteralString pragma] -> pure $ SPragma (Pragma pragma)- Parse.Symbol "macro":Parse.Symbol macroName:Parse.SExpression arguments:body:whereBindings ->+ 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] ->@@ -253,6 +262,18 @@ in STypeSynonym <$> (TypeSynonym <$> normalizedAlias <*> normalizedDef) _ -> throwError $ NormalizeError "Invalid statement!" [expr] where+ normalizeMacroImportSpec ctxt importSpec =+ case importSpec of+ Parse.SExpression macroImportList ->+ traverse+ (\case+ Parse.Symbol import' -> pure import'+ x ->+ throwError $ NormalizeError "Invalid macro import!" [x, ctxt])+ macroImportList+ x ->+ throwError $+ NormalizeError "Invalid macro import specification!" [x, ctxt] normalizeImportSpec ctxt importSpec = case importSpec of Parse.Symbol "all" -> pure ImportAll
src/Axel/Parse/AST.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} @@ -7,6 +8,7 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef) import Data.Semigroup ((<>))+import Data.Typeable (Typeable) import System.IO.Unsafe (unsafePerformIO) @@ -19,7 +21,7 @@ | LiteralString String | SExpression [Expression] | Symbol String- deriving (Eq, Show)+ deriving (Eq, Show, Typeable) -- ****************************** -- Internal utilities@@ -61,3 +63,11 @@ 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)
src/Axel/Parse/Args.hs view
@@ -1,36 +1,26 @@ module Axel.Parse.Args where-import Axel.Parse.AST as AST+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) -mdo' :: ((->) ([] AST.Expression) AST.Expression)-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--data Command = File FilePath+data Command = Convert FilePath+ | File FilePath | Project | Version--commandParser :: (Parser Command) commandParser = (subparser- ((<>) projectCommand ((<>) fileCommand versionCommand)))- where fileCommand+ ((<>) 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")))@@ -44,67 +34,5 @@ (info (pure Version) (progDesc "Display the version of the Axel compiler"))) where-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-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-def_AXEL_AUTOGENERATED_MACRO_DEFINITION- ((:) name ((:) typeSig cases))- = (pure- ((:)- (AST.SExpression (concat [[(AST.Symbol "::")], [name], [typeSig]]))- (map- (\ x ->- (AST.SExpression- (concat [[(AST.Symbol "=")], [name], (AST.toExpressionList x)])))- cases)))- 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++commandParser :: (Parser Command)
+ src/Axel/Utils/Lens.hs view
@@ -0,0 +1,6 @@+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
test/Axel/Test/ASTGen.hs view
@@ -27,6 +27,9 @@ AST.FunctionApplication <$> genExpression <*> Gen.list (Range.linear 0 3) genExpression +genIfBlock :: (MonadGen m) => m AST.IfBlock+genIfBlock = AST.IfBlock <$> genExpression <*> genExpression <*> genExpression+ genLambda :: (MonadGen m) => m AST.Lambda genLambda = AST.Lambda <$> Gen.list (Range.linear 0 3) genExpression <*> genExpression@@ -60,6 +63,7 @@ , AST.ELambda <$> genLambda , AST.ELetBlock <$> genLetBlock , AST.ELiteral <$> genLiteral+ , AST.EIfBlock <$> genIfBlock , AST.ERawExpression <$> genRawExpression , AST.ERecordDefinition <$> genRecordDefinition , AST.ERecordType <$> genRecordType@@ -98,18 +102,23 @@ Gen.list (Range.linear 0 3) genIdentifier ] -genImportSpecification :: (MonadGen m) => m AST.ImportSpecification-genImportSpecification =- Gen.choice- [ pure AST.ImportAll- , AST.ImportOnly <$> Gen.list (Range.linear 0 3) genImport- ]+genImportSpecification :: (MonadGen m) => Bool -> m AST.ImportSpecification+genImportSpecification importAll =+ let options =+ (AST.ImportOnly <$> Gen.list (Range.linear 0 3) genImport) :+ [pure AST.ImportAll | importAll]+ in Gen.choice options genQualifiedImport :: (MonadGen m) => m AST.QualifiedImport genQualifiedImport = AST.QualifiedImport <$> genIdentifier <*> genIdentifier <*>- genImportSpecification+ genImportSpecification True +genMacroImport :: (MonadGen m) => m AST.MacroImport+genMacroImport =+ AST.MacroImport <$> genIdentifier <*>+ Gen.list (Range.linear 0 3) genIdentifier+ genNewtypeDeclaration :: (MonadGen m) => m AST.NewtypeDeclaration genNewtypeDeclaration = AST.NewtypeDeclaration <$> genTypeDefinition <*> genFunctionApplication@@ -117,9 +126,9 @@ genRawStatement :: (MonadGen m) => m String genRawStatement = Gen.string (Range.linear 0 10) Gen.unicode -genRestrictedImport :: (MonadGen m) => m AST.RestrictedImport-genRestrictedImport =- AST.RestrictedImport <$> genIdentifier <*> genImportSpecification+genRestrictedImport :: (MonadGen m) => Bool -> m AST.RestrictedImport+genRestrictedImport importAll =+ AST.RestrictedImport <$> genIdentifier <*> genImportSpecification importAll genTopLevel :: (MonadGen m) => m AST.TopLevel genTopLevel = AST.TopLevel <$> Gen.list (Range.linear 0 3) genStatement@@ -147,10 +156,11 @@ Gen.choice [ AST.SDataDeclaration <$> genDataDeclaration , AST.SPragma <$> genPragma+ , AST.SMacroImport <$> genMacroImport , AST.SModuleDeclaration <$> genIdentifier , AST.SQualifiedImport <$> genQualifiedImport , AST.SRawStatement <$> genRawStatement- , AST.SRestrictedImport <$> genRestrictedImport+ , AST.SRestrictedImport <$> genRestrictedImport True , AST.STypeclassDefinition <$> genTypeclassDefinition , AST.STypeclassInstance <$> genTypeclassInstance , AST.STypeSignature <$> genTypeSignature
+ test/Axel/Test/Eff/GhciMock.hs view
@@ -0,0 +1,50 @@+{-# 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.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++data GhciState = GhciState+ { _ghciExecutionLog :: [String]+ , _ghciMockResults :: [[String]]+ } deriving (Eq, Show)++makeFieldsNoPrefix ''GhciState++mkGhciState :: [[String]] -> GhciState+mkGhciState = GhciState []++runGhci ::+ forall effs a. (Member (Effs.Error String) effs)+ => GhciState+ -> Eff (Effs.Ghci ': effs) a+ -> Eff effs (a, GhciState)+runGhci origState action = runState origState $ reinterpret go action+ where+ go :: Ghci b -> Eff (Effs.State GhciState ': effs) b+ go (Exec _ command) = do+ modify @GhciState $ ghciExecutionLog %~ (|> command)+ gets @GhciState (uncons . (^. ghciMockResults)) >>= \case+ Just (mockResult, newMockResults) -> do+ modify @GhciState $ ghciMockResults .~ newMockResults+ pure mockResult+ Nothing ->+ throwInterpretError @GhciState "Exec" "No mock result available"+ go Start = undefined+ go (Stop _) = undefined
test/Axel/Test/Eff/ProcessMock.hs view
@@ -86,7 +86,7 @@ Nothing -> throwInterpretError @(ProcessState effs)- "runProcess"+ "RunProcess" "No mock result available" go (RunProcessInheritingStreams cmd args) = do modify @(ProcessState effs) $
test/Axel/Test/File/FileSpec.hs view
@@ -4,15 +4,20 @@ 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@@ -31,6 +36,8 @@ 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/MockUtils.hs view
@@ -25,5 +25,6 @@ "\n----------\n" throwError errorMsg -unwrapRight :: Either b a -> a+unwrapRight :: (Show b) => Either b a -> a unwrapRight (Right x) = x+unwrapRight (Left x) = error $ show x