axel 0.0.4 → 0.0.5
raw patch · 59 files changed
+2718/−866 lines, 59 filesdep +bytestringdep +haskell-src-extsdep +hedgehogdep −monad-controldep ~filepathdep ~lensdep ~splitPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: bytestring, haskell-src-exts, hedgehog, optparse-applicative, tasty, tasty-discover, tasty-golden, tasty-hedgehog, tasty-hspec, template-haskell, transformers
Dependencies removed: monad-control
Dependency ranges changed: filepath, lens, split
API changes (from Hackage documentation)
- Axel.Project: addAxelDependency :: IO ()
- Axel.Project: buildProject :: IO ()
- Axel.Project: newProject :: String -> IO ()
- Axel.Project: runProject :: IO ()
- Axel.Project: transpileProject :: IO [FilePath]
+ Axel.AST: CaseBlock :: Expression -> [(Expression, Expression)] -> CaseBlock
+ Axel.AST: DataDeclaration :: TypeDefinition -> [FunctionApplication] -> DataDeclaration
+ Axel.AST: ECaseBlock :: CaseBlock -> Expression
+ Axel.AST: EEmptySExpression :: Expression
+ Axel.AST: EFunctionApplication :: FunctionApplication -> Expression
+ Axel.AST: EIdentifier :: Identifier -> Expression
+ Axel.AST: ELambda :: Lambda -> Expression
+ Axel.AST: ELetBlock :: LetBlock -> Expression
+ Axel.AST: ELiteral :: Literal -> Expression
+ Axel.AST: FunctionApplication :: Expression -> [Expression] -> FunctionApplication
+ Axel.AST: FunctionDefinition :: Identifier -> [Expression] -> Expression -> FunctionDefinition
+ Axel.AST: ImportAll :: ImportSpecification
+ Axel.AST: ImportItem :: Identifier -> Import
+ Axel.AST: ImportOnly :: [Import] -> ImportSpecification
+ Axel.AST: ImportType :: Identifier -> [Identifier] -> Import
+ Axel.AST: LChar :: Char -> Literal
+ Axel.AST: LInt :: Int -> Literal
+ Axel.AST: LString :: String -> Literal
+ Axel.AST: Lambda :: [Expression] -> Expression -> Lambda
+ Axel.AST: LetBlock :: [(Expression, Expression)] -> Expression -> LetBlock
+ Axel.AST: MacroDefinition :: FunctionDefinition -> MacroDefinition
+ Axel.AST: Pragma :: String -> Pragma
+ Axel.AST: ProperType :: Identifier -> TypeDefinition
+ Axel.AST: QualifiedImport :: Identifier -> Identifier -> ImportSpecification -> QualifiedImport
+ Axel.AST: RestrictedImport :: Identifier -> ImportSpecification -> RestrictedImport
+ Axel.AST: SDataDeclaration :: DataDeclaration -> Statement
+ Axel.AST: SFunctionDefinition :: FunctionDefinition -> Statement
+ Axel.AST: SMacroDefinition :: MacroDefinition -> Statement
+ Axel.AST: SModuleDeclaration :: Identifier -> Statement
+ Axel.AST: SPragma :: Pragma -> Statement
+ Axel.AST: SQualifiedImport :: QualifiedImport -> Statement
+ Axel.AST: SRestrictedImport :: RestrictedImport -> Statement
+ Axel.AST: STopLevel :: TopLevel -> Statement
+ Axel.AST: STypeSignature :: TypeSignature -> Statement
+ Axel.AST: STypeSynonym :: TypeSynonym -> Statement
+ Axel.AST: STypeclassInstance :: TypeclassInstance -> Statement
+ Axel.AST: SUnrestrictedImport :: Identifier -> Statement
+ Axel.AST: TopLevel :: [Statement] -> TopLevel
+ Axel.AST: TypeConstructor :: FunctionApplication -> TypeDefinition
+ Axel.AST: TypeSignature :: Identifier -> Expression -> TypeSignature
+ Axel.AST: TypeSynonym :: Expression -> Expression -> TypeSynonym
+ Axel.AST: TypeclassInstance :: Expression -> [FunctionDefinition] -> TypeclassInstance
+ Axel.AST: [$sel:_alias:QualifiedImport] :: QualifiedImport -> Identifier
+ Axel.AST: [$sel:_alias:TypeSynonym] :: TypeSynonym -> Expression
+ Axel.AST: [$sel:_arguments:FunctionApplication] :: FunctionApplication -> [Expression]
+ Axel.AST: [$sel:_arguments:FunctionDefinition] :: FunctionDefinition -> [Expression]
+ Axel.AST: [$sel:_arguments:Lambda] :: Lambda -> [Expression]
+ Axel.AST: [$sel:_bindings:LetBlock] :: LetBlock -> [(Expression, Expression)]
+ Axel.AST: [$sel:_body:FunctionDefinition] :: FunctionDefinition -> Expression
+ Axel.AST: [$sel:_body:Lambda] :: Lambda -> Expression
+ Axel.AST: [$sel:_body:LetBlock] :: LetBlock -> Expression
+ Axel.AST: [$sel:_constructors:DataDeclaration] :: DataDeclaration -> [FunctionApplication]
+ Axel.AST: [$sel:_definition:TypeSynonym] :: TypeSynonym -> Expression
+ Axel.AST: [$sel:_definitions:TypeclassInstance] :: TypeclassInstance -> [FunctionDefinition]
+ Axel.AST: [$sel:_expr:CaseBlock] :: CaseBlock -> Expression
+ Axel.AST: [$sel:_function:FunctionApplication] :: FunctionApplication -> Expression
+ Axel.AST: [$sel:_functionDefinition:MacroDefinition] :: MacroDefinition -> FunctionDefinition
+ Axel.AST: [$sel:_imports:QualifiedImport] :: QualifiedImport -> ImportSpecification
+ Axel.AST: [$sel:_imports:RestrictedImport] :: RestrictedImport -> ImportSpecification
+ Axel.AST: [$sel:_instanceName:TypeclassInstance] :: TypeclassInstance -> Expression
+ Axel.AST: [$sel:_matches:CaseBlock] :: CaseBlock -> [(Expression, Expression)]
+ Axel.AST: [$sel:_moduleName:QualifiedImport] :: QualifiedImport -> Identifier
+ Axel.AST: [$sel:_moduleName:RestrictedImport] :: RestrictedImport -> Identifier
+ Axel.AST: [$sel:_name:FunctionDefinition] :: FunctionDefinition -> Identifier
+ Axel.AST: [$sel:_name:TypeSignature] :: TypeSignature -> Identifier
+ Axel.AST: [$sel:_pragmaSpecification:Pragma] :: Pragma -> String
+ Axel.AST: [$sel:_statements:TopLevel] :: TopLevel -> [Statement]
+ Axel.AST: [$sel:_typeDefinition:DataDeclaration] :: DataDeclaration -> TypeDefinition
+ Axel.AST: [$sel:_typeDefinition:TypeSignature] :: TypeSignature -> Expression
+ Axel.AST: alias :: HasAlias s a => Lens' s a
+ Axel.AST: arguments :: HasArguments s a => Lens' s a
+ Axel.AST: bindings :: HasBindings s a => Lens' s a
+ Axel.AST: body :: HasBody s a => Lens' s a
+ Axel.AST: class HasAlias s a | s -> a
+ Axel.AST: class HasArguments s a | s -> a
+ Axel.AST: class HasBindings s a | s -> a
+ Axel.AST: class HasBody s a | s -> a
+ Axel.AST: class HasConstructors s a | s -> a
+ Axel.AST: class HasDefinition s a | s -> a
+ Axel.AST: class HasDefinitions s a | s -> a
+ Axel.AST: class HasExpr s a | s -> a
+ Axel.AST: class HasFunction s a | s -> a
+ Axel.AST: class HasFunctionDefinition s a | s -> a
+ Axel.AST: class HasImports s a | s -> a
+ Axel.AST: class HasInstanceName s a | s -> a
+ Axel.AST: class HasMatches s a | s -> a
+ Axel.AST: class HasModuleName s a | s -> a
+ Axel.AST: class HasName s a | s -> a
+ Axel.AST: class HasPragmaSpecification s a | s -> a
+ Axel.AST: class HasStatements s a | s -> a
+ Axel.AST: class HasTypeDefinition s a | s -> a
+ Axel.AST: class ToHaskell a
+ Axel.AST: constructors :: HasConstructors s a => Lens' s a
+ Axel.AST: data CaseBlock
+ Axel.AST: data DataDeclaration
+ Axel.AST: data Expression
+ Axel.AST: data FunctionApplication
+ Axel.AST: data FunctionDefinition
+ Axel.AST: data Import
+ Axel.AST: data ImportSpecification
+ Axel.AST: data Lambda
+ Axel.AST: data LetBlock
+ Axel.AST: data Literal
+ Axel.AST: data QualifiedImport
+ Axel.AST: data RestrictedImport
+ Axel.AST: data Statement
+ Axel.AST: data TypeDefinition
+ Axel.AST: data TypeSignature
+ Axel.AST: data TypeSynonym
+ Axel.AST: data TypeclassInstance
+ Axel.AST: definition :: HasDefinition s a => Lens' s a
+ Axel.AST: definitions :: HasDefinitions s a => Lens' s a
+ Axel.AST: expr :: HasExpr s a => Lens' s a
+ Axel.AST: function :: HasFunction s a => Lens' s a
+ Axel.AST: functionDefinition :: HasFunctionDefinition s a => Lens' s a
+ Axel.AST: imports :: HasImports s a => Lens' s a
+ Axel.AST: instance Axel.AST.HasAlias Axel.AST.QualifiedImport Axel.AST.Identifier
+ Axel.AST: instance Axel.AST.HasAlias Axel.AST.TypeSynonym Axel.AST.Expression
+ Axel.AST: instance Axel.AST.HasArguments Axel.AST.FunctionApplication [Axel.AST.Expression]
+ Axel.AST: instance Axel.AST.HasArguments Axel.AST.FunctionDefinition [Axel.AST.Expression]
+ Axel.AST: instance Axel.AST.HasArguments Axel.AST.Lambda [Axel.AST.Expression]
+ Axel.AST: instance Axel.AST.HasBindings Axel.AST.LetBlock [(Axel.AST.Expression, Axel.AST.Expression)]
+ Axel.AST: instance Axel.AST.HasBody Axel.AST.FunctionDefinition Axel.AST.Expression
+ Axel.AST: instance Axel.AST.HasBody Axel.AST.Lambda Axel.AST.Expression
+ Axel.AST: instance Axel.AST.HasBody Axel.AST.LetBlock Axel.AST.Expression
+ Axel.AST: instance Axel.AST.HasConstructors Axel.AST.DataDeclaration [Axel.AST.FunctionApplication]
+ Axel.AST: instance Axel.AST.HasDefinition Axel.AST.TypeSynonym Axel.AST.Expression
+ Axel.AST: instance Axel.AST.HasDefinitions Axel.AST.TypeclassInstance [Axel.AST.FunctionDefinition]
+ Axel.AST: instance Axel.AST.HasExpr Axel.AST.CaseBlock Axel.AST.Expression
+ Axel.AST: instance Axel.AST.HasFunction Axel.AST.FunctionApplication Axel.AST.Expression
+ Axel.AST: instance Axel.AST.HasFunctionDefinition Axel.AST.MacroDefinition Axel.AST.FunctionDefinition
+ Axel.AST: instance Axel.AST.HasImports Axel.AST.QualifiedImport Axel.AST.ImportSpecification
+ Axel.AST: instance Axel.AST.HasImports Axel.AST.RestrictedImport Axel.AST.ImportSpecification
+ Axel.AST: instance Axel.AST.HasInstanceName Axel.AST.TypeclassInstance Axel.AST.Expression
+ Axel.AST: instance Axel.AST.HasMatches Axel.AST.CaseBlock [(Axel.AST.Expression, Axel.AST.Expression)]
+ Axel.AST: instance Axel.AST.HasModuleName Axel.AST.QualifiedImport Axel.AST.Identifier
+ Axel.AST: instance Axel.AST.HasModuleName Axel.AST.RestrictedImport Axel.AST.Identifier
+ Axel.AST: instance Axel.AST.HasName Axel.AST.FunctionDefinition Axel.AST.Identifier
+ Axel.AST: instance Axel.AST.HasName Axel.AST.TypeSignature Axel.AST.Identifier
+ Axel.AST: instance Axel.AST.HasPragmaSpecification Axel.AST.Pragma GHC.Base.String
+ Axel.AST: instance Axel.AST.HasStatements Axel.AST.TopLevel [Axel.AST.Statement]
+ Axel.AST: instance Axel.AST.HasTypeDefinition Axel.AST.DataDeclaration Axel.AST.TypeDefinition
+ Axel.AST: instance Axel.AST.HasTypeDefinition Axel.AST.TypeSignature Axel.AST.Expression
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.CaseBlock
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.DataDeclaration
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.Expression
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.FunctionApplication
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.FunctionDefinition
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.Import
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.ImportSpecification
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.Lambda
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.LetBlock
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.Literal
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.MacroDefinition
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.Pragma
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.QualifiedImport
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.RestrictedImport
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.Statement
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.TopLevel
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.TypeDefinition
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.TypeSignature
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.TypeSynonym
+ Axel.AST: instance Axel.AST.ToHaskell Axel.AST.TypeclassInstance
+ Axel.AST: instance Axel.Utils.Recursion.Recursive Axel.AST.Expression
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.CaseBlock
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.DataDeclaration
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.Expression
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.FunctionApplication
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.FunctionDefinition
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.Import
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.ImportSpecification
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.Lambda
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.LetBlock
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.Literal
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.MacroDefinition
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.Pragma
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.QualifiedImport
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.RestrictedImport
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.Statement
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.TopLevel
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.TypeDefinition
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.TypeSignature
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.TypeSynonym
+ Axel.AST: instance GHC.Classes.Eq Axel.AST.TypeclassInstance
+ Axel.AST: instance GHC.Show.Show Axel.AST.CaseBlock
+ Axel.AST: instance GHC.Show.Show Axel.AST.DataDeclaration
+ Axel.AST: instance GHC.Show.Show Axel.AST.Expression
+ Axel.AST: instance GHC.Show.Show Axel.AST.FunctionApplication
+ Axel.AST: instance GHC.Show.Show Axel.AST.FunctionDefinition
+ Axel.AST: instance GHC.Show.Show Axel.AST.Import
+ Axel.AST: instance GHC.Show.Show Axel.AST.ImportSpecification
+ Axel.AST: instance GHC.Show.Show Axel.AST.Lambda
+ Axel.AST: instance GHC.Show.Show Axel.AST.LetBlock
+ Axel.AST: instance GHC.Show.Show Axel.AST.Literal
+ Axel.AST: instance GHC.Show.Show Axel.AST.MacroDefinition
+ Axel.AST: instance GHC.Show.Show Axel.AST.Pragma
+ Axel.AST: instance GHC.Show.Show Axel.AST.QualifiedImport
+ Axel.AST: instance GHC.Show.Show Axel.AST.RestrictedImport
+ Axel.AST: instance GHC.Show.Show Axel.AST.Statement
+ Axel.AST: instance GHC.Show.Show Axel.AST.TopLevel
+ Axel.AST: instance GHC.Show.Show Axel.AST.TypeDefinition
+ Axel.AST: instance GHC.Show.Show Axel.AST.TypeSignature
+ Axel.AST: instance GHC.Show.Show Axel.AST.TypeSynonym
+ Axel.AST: instance GHC.Show.Show Axel.AST.TypeclassInstance
+ Axel.AST: instanceName :: HasInstanceName s a => Lens' s a
+ Axel.AST: matches :: HasMatches s a => Lens' s a
+ Axel.AST: moduleName :: HasModuleName s a => Lens' s a
+ Axel.AST: name :: HasName s a => Lens' s a
+ Axel.AST: newtype MacroDefinition
+ Axel.AST: newtype Pragma
+ Axel.AST: newtype TopLevel
+ Axel.AST: pragmaSpecification :: HasPragmaSpecification s a => Lens' s a
+ Axel.AST: statements :: HasStatements s a => Lens' s a
+ Axel.AST: toHaskell :: ToHaskell a => a -> String
+ Axel.AST: type Identifier = String
+ Axel.AST: type Program = [Statement]
+ Axel.AST: typeDefinition :: HasTypeDefinition s a => Lens' s a
+ Axel.Denormalize: denormalizeExpression :: Expression -> Expression
+ Axel.Denormalize: denormalizeImportSpecification :: ImportSpecification -> Expression
+ Axel.Denormalize: denormalizeStatement :: Statement -> Expression
+ Axel.Error: EvalError :: String -> Error
+ Axel.Error: MacroError :: String -> Error
+ Axel.Error: NormalizeError :: String -> [Expression] -> Error
+ Axel.Error: ParseError :: String -> Error
+ Axel.Error: ProjectError :: String -> Error
+ Axel.Error: data Error
+ Axel.Error: fatal :: String -> String -> a
+ Axel.Error: instance GHC.Show.Show Axel.Error.Error
+ Axel.Error: mapError :: (MonadError e' m) => ExceptT e m a -> (e -> e') -> m a
+ Axel.Error: toIO :: (MonadError IOError m) => ExceptT Error m a -> m a
+ Axel.Haskell.File: axelPathToHaskellPath :: FilePath -> FilePath
+ Axel.Haskell.File: convertList :: Expression -> Expression
+ Axel.Haskell.File: convertUnit :: Expression -> Expression
+ Axel.Haskell.File: evalFile :: (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => FilePath -> m ()
+ Axel.Haskell.File: transpileFile :: (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => FilePath -> FilePath -> m ()
+ Axel.Haskell.File: transpileFile' :: (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => FilePath -> m FilePath
+ Axel.Haskell.File: transpileSource :: (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => String -> m String
+ Axel.Haskell.GHC: ghcCompile :: (MonadError String m, MonadProcess m) => FilePath -> m String
+ Axel.Haskell.GHC: ghcInterpret :: (MonadError String m, MonadProcess m) => FilePath -> m String
+ Axel.Haskell.Prettify: prettifyHaskell :: String -> String
+ Axel.Haskell.Project: buildProject :: (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => m ()
+ Axel.Haskell.Project: newProject :: (MonadFileSystem m, MonadProcess m, MonadResource m) => String -> m ()
+ Axel.Haskell.Project: runProject :: (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m) => m ()
+ Axel.Haskell.Project: transpileProject :: (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => m [FilePath]
+ Axel.Haskell.Project: type ProjectPath = FilePath
+ Axel.Haskell.Stack: addStackDependency :: (MonadFileSystem m) => StackageId -> ProjectPath -> m ()
+ Axel.Haskell.Stack: axelStackageId :: StackageId
+ Axel.Haskell.Stack: axelStackageSpecifier :: StackageId
+ Axel.Haskell.Stack: axelStackageVersion :: Version
+ Axel.Haskell.Stack: buildStackProject :: (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m) => ProjectPath -> m ()
+ Axel.Haskell.Stack: createStackProject :: (MonadFileSystem m, MonadProcess m) => String -> m ()
+ Axel.Haskell.Stack: getStackProjectTargets :: (Monad m, MonadFileSystem m, MonadProcess m) => ProjectPath -> m [Target]
+ Axel.Haskell.Stack: runStackProject :: (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m) => ProjectPath -> m ()
+ Axel.Haskell.Stack: setStackageResolver :: (MonadFileSystem m, MonadProcess m) => ProjectPath -> StackageResolver -> m ()
+ Axel.Haskell.Stack: stackageResolverWithAxel :: StackageResolver
+ Axel.Haskell.Stack: type ProjectPath = FilePath
+ Axel.Haskell.Stack: type StackageId = String
+ Axel.Haskell.Stack: type StackageResolver = String
+ Axel.Haskell.Stack: type Target = String
+ Axel.Haskell.Stack: type Version = String
+ Axel.Macros: evalMacro :: (MonadError Error m, MonadFileSystem m, MonadProcess m) => String -> String -> String -> m String
+ Axel.Macros: exhaustivelyExpandMacros :: (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => Expression -> m Expression
+ Axel.Macros: expandMacroApplication :: (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => NonEmpty MacroDefinition -> [Statement] -> [Expression] -> m [Expression]
+ Axel.Macros: expandMacros :: (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => [Expression] -> m [Statement]
+ Axel.Macros: expansionPass :: (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => Expression -> m Expression
+ Axel.Macros: generateMacroProgram :: (MonadError Error m, MonadFileSystem m, MonadResource m) => NonEmpty MacroDefinition -> [Statement] -> [Expression] -> m (String, String, String)
+ Axel.Macros: isMacroBeingCalled :: MacroDefinition -> Expression -> Bool
+ Axel.Macros: isMacroDefinitionStatement :: Statement -> Bool
+ Axel.Macros: isStatementNonconflicting :: Statement -> Bool
+ Axel.Macros: lookupMacroDefinitions :: Expression -> [MacroDefinition] -> Maybe (NonEmpty MacroDefinition)
+ Axel.Macros: programToTopLevelExpressions :: Expression -> [Expression]
+ Axel.Macros: replaceName :: (MonadError Error m) => Identifier -> Identifier -> Statement -> m Statement
+ Axel.Macros: stripMacroDefinitions :: Statement -> Statement
+ Axel.Macros: topLevelExpressionsToProgram :: [Expression] -> Expression
+ Axel.Monad.Console: class (Monad m) => MonadConsole m
+ Axel.Monad.Console: instance (GHC.Base.Monad m, Control.Monad.IO.Class.MonadIO m) => Axel.Monad.Console.MonadConsole m
+ Axel.Monad.Console: instance (GHC.Base.Monoid w, Axel.Monad.Console.MonadConsole m) => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.RWS.Lazy.RWST r w s m)
+ Axel.Monad.Console: instance (GHC.Base.Monoid w, Axel.Monad.Console.MonadConsole m) => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.RWS.Strict.RWST r w s m)
+ Axel.Monad.Console: instance (GHC.Base.Monoid w, Axel.Monad.Console.MonadConsole m) => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.Writer.Lazy.WriterT w m)
+ Axel.Monad.Console: instance (GHC.Base.Monoid w, Axel.Monad.Console.MonadConsole m) => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.Writer.Strict.WriterT w m)
+ Axel.Monad.Console: instance Axel.Monad.Console.MonadConsole m => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.Cont.ContT r m)
+ Axel.Monad.Console: instance Axel.Monad.Console.MonadConsole m => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.Except.ExceptT e m)
+ Axel.Monad.Console: instance Axel.Monad.Console.MonadConsole m => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.Identity.IdentityT m)
+ Axel.Monad.Console: instance Axel.Monad.Console.MonadConsole m => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.Maybe.MaybeT m)
+ Axel.Monad.Console: instance Axel.Monad.Console.MonadConsole m => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.Reader.ReaderT r m)
+ Axel.Monad.Console: instance Axel.Monad.Console.MonadConsole m => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.State.Lazy.StateT s m)
+ Axel.Monad.Console: instance Axel.Monad.Console.MonadConsole m => Axel.Monad.Console.MonadConsole (Control.Monad.Trans.State.Strict.StateT s m)
+ Axel.Monad.Console: putStr :: (MonadConsole m, MonadTrans t, MonadConsole m', m ~ t m') => String -> m ()
+ Axel.Monad.Console: putStrLn :: (MonadConsole m) => String -> m ()
+ Axel.Monad.FileSystem: class (Monad m) => MonadFileSystem m
+ Axel.Monad.FileSystem: copyFile :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> FilePath -> m ()
+ Axel.Monad.FileSystem: createDirectoryIfMissing :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => Bool -> FilePath -> m ()
+ Axel.Monad.FileSystem: doesDirectoryExist :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m Bool
+ Axel.Monad.FileSystem: getCurrentDirectory :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => m FilePath
+ Axel.Monad.FileSystem: getDirectoryContents :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m [FilePath]
+ Axel.Monad.FileSystem: getDirectoryContentsRec :: (Monad m, MonadFileSystem m) => FilePath -> m [FilePath]
+ Axel.Monad.FileSystem: getTemporaryDirectory :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => m FilePath
+ Axel.Monad.FileSystem: instance (GHC.Base.Monad m, Control.Monad.IO.Class.MonadIO m) => Axel.Monad.FileSystem.MonadFileSystem m
+ Axel.Monad.FileSystem: instance (GHC.Base.Monoid w, Axel.Monad.FileSystem.MonadFileSystem m) => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.RWS.Lazy.RWST r w s m)
+ Axel.Monad.FileSystem: instance (GHC.Base.Monoid w, Axel.Monad.FileSystem.MonadFileSystem m) => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.RWS.Strict.RWST r w s m)
+ Axel.Monad.FileSystem: instance (GHC.Base.Monoid w, Axel.Monad.FileSystem.MonadFileSystem m) => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.Writer.Lazy.WriterT w m)
+ Axel.Monad.FileSystem: instance (GHC.Base.Monoid w, Axel.Monad.FileSystem.MonadFileSystem m) => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.Writer.Strict.WriterT w m)
+ Axel.Monad.FileSystem: instance Axel.Monad.FileSystem.MonadFileSystem m => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.Cont.ContT r m)
+ Axel.Monad.FileSystem: instance Axel.Monad.FileSystem.MonadFileSystem m => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.Except.ExceptT e m)
+ Axel.Monad.FileSystem: instance Axel.Monad.FileSystem.MonadFileSystem m => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.Identity.IdentityT m)
+ Axel.Monad.FileSystem: instance Axel.Monad.FileSystem.MonadFileSystem m => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.Maybe.MaybeT m)
+ Axel.Monad.FileSystem: instance Axel.Monad.FileSystem.MonadFileSystem m => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.Reader.ReaderT r m)
+ Axel.Monad.FileSystem: instance Axel.Monad.FileSystem.MonadFileSystem m => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.State.Lazy.StateT s m)
+ Axel.Monad.FileSystem: instance Axel.Monad.FileSystem.MonadFileSystem m => Axel.Monad.FileSystem.MonadFileSystem (Control.Monad.Trans.State.Strict.StateT s m)
+ Axel.Monad.FileSystem: readFile :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m String
+ Axel.Monad.FileSystem: removeFile :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m ()
+ Axel.Monad.FileSystem: setCurrentDirectory :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => FilePath -> m ()
+ Axel.Monad.FileSystem: withCurrentDirectory :: (MonadFileSystem m) => FilePath -> m a -> m a
+ Axel.Monad.FileSystem: withTemporaryDirectory :: (MonadFileSystem m) => (FilePath -> m a) -> m a
+ Axel.Monad.FileSystem: writeFile :: (MonadFileSystem m, MonadTrans t, MonadFileSystem m', m ~ t m') => String -> FilePath -> m ()
+ Axel.Monad.Process: class (Monad m) => MonadProcess m
+ Axel.Monad.Process: getArgs :: (MonadProcess m, MonadTrans t, MonadProcess m', m ~ t m') => m [String]
+ Axel.Monad.Process: instance (GHC.Base.Monad m, Control.Monad.IO.Class.MonadIO m) => Axel.Monad.Process.MonadProcess m
+ Axel.Monad.Process: instance (GHC.Base.Monoid w, Axel.Monad.Process.MonadProcess m) => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.RWS.Lazy.RWST r w s m)
+ Axel.Monad.Process: instance (GHC.Base.Monoid w, Axel.Monad.Process.MonadProcess m) => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.RWS.Strict.RWST r w s m)
+ Axel.Monad.Process: instance (GHC.Base.Monoid w, Axel.Monad.Process.MonadProcess m) => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.Writer.Lazy.WriterT w m)
+ Axel.Monad.Process: instance (GHC.Base.Monoid w, Axel.Monad.Process.MonadProcess m) => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.Writer.Strict.WriterT w m)
+ Axel.Monad.Process: instance Axel.Monad.Process.MonadProcess m => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.Cont.ContT r m)
+ Axel.Monad.Process: instance Axel.Monad.Process.MonadProcess m => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.Except.ExceptT e m)
+ Axel.Monad.Process: instance Axel.Monad.Process.MonadProcess m => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.Identity.IdentityT m)
+ Axel.Monad.Process: instance Axel.Monad.Process.MonadProcess m => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.Maybe.MaybeT m)
+ Axel.Monad.Process: instance Axel.Monad.Process.MonadProcess m => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.Reader.ReaderT r m)
+ Axel.Monad.Process: instance Axel.Monad.Process.MonadProcess m => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.State.Lazy.StateT s m)
+ Axel.Monad.Process: instance Axel.Monad.Process.MonadProcess m => Axel.Monad.Process.MonadProcess (Control.Monad.Trans.State.Strict.StateT s m)
+ Axel.Monad.Process: runProcess :: (MonadProcess m, MonadTrans t, MonadProcess m', m ~ t m') => FilePath -> [String] -> String -> m (ExitCode, String, String)
+ Axel.Monad.Process: runProcessInheritingStreams :: (MonadProcess m, MonadTrans t, MonadProcess m', m ~ t m') => FilePath -> [String] -> m ExitCode
+ Axel.Monad.Resource: ResourceId :: String -> ResourceId
+ Axel.Monad.Resource: astDefinition :: ResourceId
+ Axel.Monad.Resource: class (Monad m) => MonadResource m
+ Axel.Monad.Resource: getResourcePath :: (MonadResource m, MonadTrans t, MonadResource m', m ~ t m') => ResourceId -> m FilePath
+ Axel.Monad.Resource: instance (GHC.Base.Monad m, Control.Monad.IO.Class.MonadIO m) => Axel.Monad.Resource.MonadResource m
+ Axel.Monad.Resource: instance (GHC.Base.Monoid w, Axel.Monad.Resource.MonadResource m) => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.RWS.Lazy.RWST r w s m)
+ Axel.Monad.Resource: instance (GHC.Base.Monoid w, Axel.Monad.Resource.MonadResource m) => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.RWS.Strict.RWST r w s m)
+ Axel.Monad.Resource: instance (GHC.Base.Monoid w, Axel.Monad.Resource.MonadResource m) => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.Writer.Lazy.WriterT w m)
+ Axel.Monad.Resource: instance (GHC.Base.Monoid w, Axel.Monad.Resource.MonadResource m) => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.Writer.Strict.WriterT w m)
+ Axel.Monad.Resource: instance Axel.Monad.Resource.MonadResource m => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.Cont.ContT r m)
+ Axel.Monad.Resource: instance Axel.Monad.Resource.MonadResource m => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.Except.ExceptT e m)
+ Axel.Monad.Resource: instance Axel.Monad.Resource.MonadResource m => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.Identity.IdentityT m)
+ Axel.Monad.Resource: instance Axel.Monad.Resource.MonadResource m => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.Maybe.MaybeT m)
+ Axel.Monad.Resource: instance Axel.Monad.Resource.MonadResource m => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.Reader.ReaderT r m)
+ Axel.Monad.Resource: instance Axel.Monad.Resource.MonadResource m => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.State.Lazy.StateT s m)
+ Axel.Monad.Resource: instance Axel.Monad.Resource.MonadResource m => Axel.Monad.Resource.MonadResource (Control.Monad.Trans.State.Strict.StateT s m)
+ Axel.Monad.Resource: macroDefinitionAndEnvironmentFooter :: ResourceId
+ Axel.Monad.Resource: macroDefinitionAndEnvironmentHeader :: ResourceId
+ Axel.Monad.Resource: macroScaffold :: ResourceId
+ Axel.Monad.Resource: newProjectTemplate :: ResourceId
+ Axel.Monad.Resource: newtype ResourceId
+ Axel.Monad.Resource: readResource :: (MonadFileSystem m, MonadResource m) => ResourceId -> m String
+ Axel.Normalize: normalizeExpression :: (MonadError Error m) => Expression -> m Expression
+ Axel.Normalize: normalizeFunctionDefinition :: (MonadError Error m) => Identifier -> [Expression] -> Expression -> m FunctionDefinition
+ Axel.Normalize: normalizeStatement :: (MonadError Error m) => Expression -> m Statement
+ Axel.Parse: LiteralChar :: Char -> Expression
+ Axel.Parse: LiteralInt :: Int -> Expression
+ Axel.Parse: LiteralString :: String -> Expression
+ Axel.Parse: SExpression :: [Expression] -> Expression
+ Axel.Parse: Symbol :: String -> Expression
+ Axel.Parse: any' :: (Stream s m Char) => ParsecT s u m Char
+ Axel.Parse: data Expression
+ Axel.Parse: expression :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: instance Axel.Utils.Recursion.Recursive Axel.Parse.AST.Expression
+ Axel.Parse: literalChar :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: literalInt :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: literalList :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: literalString :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: parseMultiple :: (MonadError Error m) => String -> m [Expression]
+ Axel.Parse: parseReadMacro :: (Stream s m Char) => String -> String -> ParsecT s u m Expression
+ Axel.Parse: parseSingle :: (MonadError Error m) => String -> m Expression
+ Axel.Parse: parseSource :: (MonadError Error m) => String -> m Expression
+ Axel.Parse: programToTopLevelExpressions :: Expression -> [Expression]
+ Axel.Parse: quasiquotedExpression :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: quoteParseExpression :: Expression -> Expression
+ Axel.Parse: quotedExpression :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: sExpression :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: spliceUnquotedExpression :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: stripComments :: String -> String
+ Axel.Parse: symbol :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: topLevelExpressionsToProgram :: [Expression] -> Expression
+ Axel.Parse: unquotedExpression :: (Stream s m Char) => ParsecT s u m Expression
+ Axel.Parse: whitespace :: (Stream s m Char) => ParsecT s u m String
+ Axel.Parse.AST: class ToExpressionList a
+ Axel.Parse.AST: instance Axel.Parse.AST.ToExpressionList Axel.Parse.AST.Expression
+ Axel.Parse.AST: instance Axel.Parse.AST.ToExpressionList [Axel.Parse.AST.Expression]
+ Axel.Parse.AST: toExpressionList :: ToExpressionList a => a -> [Expression]
+ Axel.Parse.Args: File :: FilePath -> ModeCommand
+ Axel.Parse.Args: Project :: ModeCommand
+ Axel.Parse.Args: data ModeCommand
+ Axel.Parse.Args: modeCommandParser :: Parser ModeCommand
+ Axel.Utils.Debug: unsafeTee :: String -> String
+ Axel.Utils.Debug: unsafeTee' :: (a -> String) -> a -> a
+ Axel.Utils.Debug: unsafeTeeS :: Show a => a -> a
+ Axel.Utils.Debug: unsafeTeeS' :: Show b => (a -> b) -> a -> a
+ Axel.Utils.Display: Commas :: Delimiter
+ Axel.Utils.Display: CurlyBraces :: Bracket
+ Axel.Utils.Display: DoubleQuotes :: Bracket
+ Axel.Utils.Display: Newlines :: Delimiter
+ Axel.Utils.Display: Parentheses :: Bracket
+ Axel.Utils.Display: Pipes :: Delimiter
+ Axel.Utils.Display: Semicolons :: Delimiter
+ Axel.Utils.Display: SingleQuotes :: Bracket
+ Axel.Utils.Display: Spaces :: Delimiter
+ Axel.Utils.Display: SquareBrackets :: Bracket
+ Axel.Utils.Display: data Bracket
+ Axel.Utils.Display: data Delimiter
+ Axel.Utils.Display: delimit :: Delimiter -> [String] -> String
+ Axel.Utils.Display: isOperator :: String -> Bool
+ Axel.Utils.Display: lowerFirst :: String -> String
+ Axel.Utils.Display: renderBlock :: [String] -> String
+ Axel.Utils.Display: renderPragma :: String -> String
+ Axel.Utils.Display: surround :: Bracket -> String -> String
+ Axel.Utils.Display: upperFirst :: String -> String
+ Axel.Utils.Function: uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+ Axel.Utils.List: takeUntil :: (Eq a) => [a] -> [a] -> [a]
+ Axel.Utils.Recursion: bottomUpFmap :: Recursive a => (a -> a) -> a -> a
+ Axel.Utils.Recursion: bottomUpTraverse :: (Recursive a, (Monad m)) => (a -> m a) -> a -> m a
+ Axel.Utils.Recursion: class Recursive a
+ Axel.Utils.Recursion: exhaustM :: (Eq a, Monad m) => (a -> m a) -> a -> m a
+ Axel.Utils.Recursion: topDownFmap :: Recursive a => (a -> a) -> a -> a
+ Axel.Utils.String: replace :: String -> String -> String -> String
Files
- README.org +2/−2
- app/Main.hs +26/−7
- axel.cabal +68/−18
- examples/do.axel +0/−44
- examples/doNotation.axel +50/−0
- examples/example.axel +0/−30
- examples/if.axel +40/−0
- resources/autogenerated/macros/AST.hs +26/−10
- resources/macros/MacroDefinitionAndEnvironmentFooter.hs +1/−0
- resources/macros/MacroDefinitionAndEnvironmentHeader.hs +0/−2
- resources/new-project-template/Setup.hs +3/−2
- resources/new-project-template/app/Main.hs +2/−2
- resources/new-project-template/src/Lib.hs +1/−2
- resources/new-project-template/test/Spec.hs +1/−1
- scripts/format.sh +4/−0
- src/Axel/AST.hs +88/−115
- src/Axel/Denormalize.hs +51/−58
- src/Axel/Entry.hs +0/−85
- src/Axel/Error.hs +25/−6
- src/Axel/Eval.hs +0/−44
- src/Axel/GHC.hs +0/−35
- src/Axel/Haskell/File.hs +106/−0
- src/Axel/Haskell/GHC.hs +50/−0
- src/Axel/Haskell/Prettify.hs +14/−0
- src/Axel/Haskell/Project.hs +75/−0
- src/Axel/Haskell/Stack.hs +137/−0
- src/Axel/Macros.hs +178/−123
- src/Axel/Monad/Console.hs +64/−0
- src/Axel/Monad/FileSystem.hs +162/−0
- src/Axel/Monad/Process.hs +81/−0
- src/Axel/Monad/Resource.hs +90/−0
- src/Axel/Normalize.hs +50/−57
- src/Axel/Parse.hs +57/−11
- src/Axel/Parse/AST.hs +21/−1
- src/Axel/Parse/Args.hs +31/−0
- src/Axel/Project.hs +0/−92
- src/Axel/Quote.hs +0/−47
- src/Axel/Utils/Debug.hs +2/−2
- src/Axel/Utils/Directory.hs +0/−41
- src/Axel/Utils/Display.hs +3/−1
- src/Axel/Utils/Recursion.hs +1/−0
- src/Axel/Utils/Resources.hs +0/−28
- test/Axel/Test/ASTGen.hs +130/−0
- test/Axel/Test/DenormalizeSpec.hs +20/−0
- test/Axel/Test/File/FileSpec.hs +25/−0
- test/Axel/Test/Haskell/GHCSpec.hs +76/−0
- test/Axel/Test/Haskell/StackSpec.hs +115/−0
- test/Axel/Test/MockUtils.hs +35/−0
- test/Axel/Test/Monad/ConsoleMock.hs +46/−0
- test/Axel/Test/Monad/ConsoleSpec.hs +19/−0
- test/Axel/Test/Monad/FileSystemMock.hs +278/−0
- test/Axel/Test/Monad/FileSystemSpec.hs +74/−0
- test/Axel/Test/Monad/ProcessMock.hs +128/−0
- test/Axel/Test/Monad/ResourceMock.hs +40/−0
- test/Axel/Test/Monad/ResourceSpec.hs +27/−0
- test/Axel/Test/NormalizeSpec.hs +14/−0
- test/Axel/Test/Parse/ASTGen.hs +18/−0
- test/Axel/Test/ParseSpec.hs +160/−0
- test/Main.hs +3/−0
README.org view
@@ -1,11 +1,11 @@ #+OPTIONS: num:nil toc:nil * Axel Haskell + Lisp + JVM/Node/... = Profit!- + See [[https://axellang.github.io]]. ** 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~ to run ~app/Main.hs~. The executable takes one argument, the path of the Haskell program to transpile and execute.+ 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). ** Examples See the ~examples~ folder for example Axel programs.
app/Main.hs view
@@ -1,13 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module Main where -import Axel.Project (buildProject, runProject)+import Axel.Error (Error)+import qualified Axel.Error as Error (toIO)+import Axel.Haskell.File (evalFile)+import Axel.Haskell.Project (buildProject, runProject)+import Axel.Parse.Args (ModeCommand(File, Project), modeCommandParser) -import System.Directory (setCurrentDirectory)-import System.Environment (getArgs)+import Control.Monad.Except (ExceptT, MonadError)+import Control.Monad.IO.Class (MonadIO) +import Options.Applicative (execParser, info, progDesc)++newtype AppM a = AppM+ { runAppM :: ExceptT Error IO a+ } deriving (Functor, Applicative, Monad, MonadError Error, MonadIO)++runAppM' :: AppM a -> IO a+runAppM' = Error.toIO . runAppM++app :: ModeCommand -> AppM ()+app (File filePath) = evalFile filePath+app Project = buildProject >> runProject+ main :: IO () main = do- [projectPath] <- getArgs- setCurrentDirectory projectPath- buildProject- runProject+ modeCommand <-+ execParser $ info modeCommandParser (progDesc "The command to run.")+ runAppM' $ app modeCommand
axel.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: deb466082a59f53f497793cec5211f873c7f26948954aad70363885d5cd568bd+-- hash: bd98666bdad98615fa9b95dbfdbcf860ae5ad9fd5595b478e5f76d1390962147 name: axel-version: 0.0.4+version: 0.0.5 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@@ -20,15 +20,17 @@ cabal-version: >= 1.10 extra-source-files: examples/axelTemp/Axel.hs- examples/do.axel- examples/example.axel+ examples/doNotation.axel+ examples/if.axel README.org scripts/build.sh scripts/clean.sh+ scripts/format.sh scripts/ghcid.sh scripts/lint.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@@ -46,45 +48,50 @@ library exposed-modules:- Axel.Parse.AST- Axel.Project- other-modules: Axel.AST Axel.Denormalize- Axel.Entry Axel.Error- Axel.Eval- Axel.GHC+ Axel.Haskell.File+ Axel.Haskell.GHC+ Axel.Haskell.Prettify+ Axel.Haskell.Project+ Axel.Haskell.Stack Axel.Macros+ Axel.Monad.Console+ Axel.Monad.FileSystem+ Axel.Monad.Process+ Axel.Monad.Resource Axel.Normalize Axel.Parse- Axel.Quote+ Axel.Parse.Args+ Axel.Parse.AST Axel.Utils.Debug- Axel.Utils.Directory Axel.Utils.Display Axel.Utils.Function Axel.Utils.List Axel.Utils.Recursion- Axel.Utils.Resources Axel.Utils.String+ other-modules: Paths_axel hs-source-dirs: src- ghc-options: -Wall -Wcpp-undef -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wredundant-constraints+ 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 build-depends: base >=4.11.1 && <4.12+ , bytestring >=0.10.8 && <0.11 , directory >=1.3 && <1.4 , filepath >=1.4.1 && <1.5+ , haskell-src-exts >=1.20.2 && <1.21 , lens >=4.16.1 && <4.18 , lens-aeson >=1.0.2 && <1.1- , monad-control >=1.0.2 && <1.1 , mtl >=2.2.1 && <2.3+ , optparse-applicative >=0.14.2 && <0.15 , parsec >=3.1.11 && <3.2 , process >=1.6.1 && <1.7 , regex-pcre >=0.94.4 && <0.95- , split >=0.2.3 && <0.3 , strict >=0.3.2 && <0.4 , text >=1.2.2 && <1.3+ , transformers >=0.5.5 && <0.6 , typed-process >=0.2.2 && <0.3 , vector >=0.12.0 && <0.13 , yaml >=0.8.31 && <0.10@@ -96,9 +103,52 @@ Paths_axel hs-source-dirs: app- ghc-options: -Wall -Wcpp-undef -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ 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 build-depends: axel , base >=4.11.1 && <4.12- , directory >=1.3 && <1.4+ , mtl >=2.2.1 && <2.3+ , optparse-applicative >=0.14.2 && <0.15+ default-language: Haskell2010++test-suite axel-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Axel.Test.ASTGen+ Axel.Test.DenormalizeSpec+ Axel.Test.File.FileSpec+ Axel.Test.Haskell.GHCSpec+ Axel.Test.Haskell.StackSpec+ Axel.Test.MockUtils+ Axel.Test.Monad.ConsoleMock+ Axel.Test.Monad.ConsoleSpec+ Axel.Test.Monad.FileSystemMock+ Axel.Test.Monad.FileSystemSpec+ Axel.Test.Monad.ProcessMock+ Axel.Test.Monad.ResourceMock+ Axel.Test.Monad.ResourceSpec+ Axel.Test.NormalizeSpec+ Axel.Test.Parse.ASTGen+ Axel.Test.ParseSpec+ 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+ build-depends:+ axel+ , base >=4.11.1 && <4.12+ , bytestring+ , filepath+ , hedgehog+ , lens+ , mtl >=2.2.1 && <2.3+ , split+ , tasty+ , tasty-discover+ , tasty-golden+ , tasty-hedgehog+ , tasty-hspec+ , template-haskell+ , transformers default-language: Haskell2010
− examples/do.axel
@@ -1,44 +0,0 @@-(module Main)--(importq Axel.Parse.AST AST all)--(defmacro quasiquote- (([(AST.SExpression xs)])- (let ((quasiquoteElem (fn (x) (case x- ((AST.SExpression ['unquote x])- (AST.SExpression ['list x]))- ((AST.SExpression ['unquoteSplicing x])- x)- (atom- (AST.SExpression- ['list- (AST.SExpression ['quasiquote atom])]))))))- (pure [(AST.SExpression ['AST.SExpression (AST.SExpression ['concat (AST.SExpression (: 'list (map quasiquoteElem xs)))])])])))- (([atom]) (pure [(AST.SExpression ['quote atom])])))--(defmacro fnCase- ((cases) (<$> (fn (varId)- [`(fn (~varId)- (case ~varId ~@cases))])- AST.gensym)))--(= do' (-> ([] AST.Expression) AST.Expression)- (() (fnCase- ((: var (: '<- (: val rest)))- `(>>= ~val (fn (~var) ~(do' rest))))- ((: val rest)- (case rest- ([]- val)- (_- `(>> ~val ~(do' rest))))))))--(defmacro do- ((input)- (pure [(do' input)])))--(= main (IO Unit)- (() (do- line <- getLine- (putStrLn line)- (pure unit))))
+ examples/doNotation.axel view
@@ -0,0 +1,50 @@+(importq Axel.Parse.AST AST all)++-- NOTE This will eventually be automatically defined by the Axel prelude.+(macro quasiquote ([(AST.SExpression xs)])+ (let ((quasiquoteElem (\ (x) (case x+ ((AST.SExpression ['unquote x])+ (AST.SExpression ['list x]))+ ((AST.SExpression ['unquoteSplicing x])+ (AST.SExpression ['AST.toExpressionList x]))+ (atom+ (AST.SExpression+ ['list+ (AST.SExpression ['quasiquote atom])]))))))+ (pure [(AST.SExpression ['AST.SExpression (AST.SExpression ['concat (AST.SExpression (: 'list (map quasiquoteElem xs)))])])])))+(macro quasiquote ([atom])+ (pure [(AST.SExpression ['quote atom])]))++-- NOTE This will eventually be automatically defined by the Axel prelude.+(macro fnCase (cases)+ (<$> (\ (varId)+ [`(\ (~varId) (case ~varId ~@cases))])+ AST.gensym))++-- NOTE This will eventually be automatically defined by the Axel prelude.+(macro def ((: name (: typeSig cases)))+ (pure+ (: `(:: ~name ~typeSig)+ (map (\ (x) `(= ~name ~@x))+ cases))))++(def mdo' (-> (List AST.Expression) AST.Expression)+ (((: var (: '<- (: val rest))))+ `(>>= ~val (\ (~var) ~(mdo' rest))))+ (((: val rest))+ (case rest+ ([]+ val)+ (_+ `(>> ~val ~(mdo' rest))))))++-- NOTE This will eventually be automatically defined by the Axel prelude.+(macro mdo (input)+ (pure [(mdo' input)]))++(def main (IO Unit)+ (()+ (mdo+ line <- getLine+ (putStrLn line)+ (pure unit))))
− examples/example.axel
@@ -1,30 +0,0 @@--- This is just an example, and, since it's partial, is NOT advised for actual use.-(defmacro' when- (([condition body]) (pure [`(if ~condition ~body (error "WHEN"))])))--(defmacro defmacro'- ((exprs)- (pure [`(defmacro ~@exprs)])))--(defmacro if- (([cond true false])- (pure [`(case ~cond- (True ~true)- (False ~false))])))--(defmacro quasiquote- (([(AST.SExpression xs)])- (let ((quasiquoteElem (fn (x) (case x- ((AST.SExpression ['unquote x])- (AST.SExpression ['list x]))- ((AST.SExpression ['unquoteSplicing x])- x)- (atom- (AST.SExpression- ['list- (AST.SExpression ['quasiquote atom])]))))))- (pure [(AST.SExpression ['AST.SExpression (AST.SExpression ['concat (AST.SExpression (: 'list (map quasiquoteElem xs)))])])])))- (([atom]) (pure [(AST.SExpression ['quote atom])])))--(= main (IO Unit)- (() (if (== 1 1) (putStrLn "Hi!") (putStrLn "wat"))))
+ examples/if.axel view
@@ -0,0 +1,40 @@+(importq Axel.Parse.AST AST all)++-- NOTE This will eventually be automatically defined by the Axel prelude.+(macro quasiquote ([(AST.SExpression xs)])+ (let ((quasiquoteElem (\ (x) (case x+ ((AST.SExpression ['unquote x])+ (AST.SExpression ['list x]))+ ((AST.SExpression ['unquoteSplicing x])+ (AST.SExpression ['AST.toExpressionList x]))+ (atom+ (AST.SExpression+ ['list+ (AST.SExpression ['quasiquote atom])]))))))+ (pure [(AST.SExpression ['AST.SExpression (AST.SExpression ['concat (AST.SExpression (: 'list (map quasiquoteElem xs)))])])])))+(macro quasiquote ([atom])+ (pure [(AST.SExpression ['quote atom])]))++-- NOTE This will eventually be automatically defined by the Axel prelude.+(macro fnCase (cases)+ (<$> (\ (varId)+ [`(\ (~varId) (case ~varId ~@cases))])+ AST.gensym))++-- NOTE This will eventually be automatically defined by the Axel prelude.+(macro def ((: name (: typeSig cases)))+ (pure+ (: `(:: ~name ~typeSig)+ (map (\ (x) `(= ~name ~@x))+ cases))))++-- NOTE This will eventually be automatically defined by the Axel prelude.+(macro if ([cond true false])+ (pure [`(case ~cond+ (True ~true)+ (False ~false))]))++(def main (IO Unit)+ (()+ (putStrLn+ (if (== 1 1) "Correct!" "Impossible..."))))
resources/autogenerated/macros/AST.hs view
@@ -1,14 +1,13 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+ -- NOTE Because this file will be used as the header of auto-generated macro programs, -- it can't have any project-specific dependencies (such as `Fix`). module Axel.Parse.AST where -import Data.IORef ( IORef- , modifyIORef- , newIORef- , readIORef- )+import Data.IORef (IORef, modifyIORef, newIORef, readIORef) -import System.IO.Unsafe ( unsafePerformIO )+import System.IO.Unsafe (unsafePerformIO) -- TODO `Expression` should probably be `Traversable`, use recursion schemes, etc. -- I should provide `toFix` and `fromFix` functions for macros to take advantage of.@@ -25,11 +24,11 @@ -- Internal utilities -- ****************************** toAxel :: Expression -> String-toAxel (LiteralChar x ) = ['\\', x]-toAxel (LiteralInt x ) = show x+toAxel (LiteralChar x) = ['{', x, '}']+toAxel (LiteralInt x) = show x toAxel (LiteralString xs) = "\"" ++ xs ++ "\""-toAxel (SExpression xs) = "(" ++ unwords (map toAxel xs) ++ ")"-toAxel (Symbol x ) = x+toAxel (SExpression xs) = "(" ++ unwords (map toAxel xs) ++ ")"+toAxel (Symbol x) = x -- ****************************** -- Macro definition utilities@@ -44,3 +43,20 @@ let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" ++ show suffix modifyIORef gensymCounter succ pure $ Symbol identifier++-- | This allows splice-unquoting of both `[Expression]`s and `SExpression`s, without requiring special syntax for each.+class ToExpressionList a where+ toExpressionList :: a -> [Expression]++instance ToExpressionList [Expression] where+ toExpressionList :: [Expression] -> [Expression]+ 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+ toExpressionList x =+ error+ (show x <>+ " cannot be splice-unquoted, because it is not an s-expression!")
@@ -0,0 +1,1 @@+%%%MACRO_NAME%%% :: [AST.Expression] -> IO [AST.Expression]
resources/macros/MacroDefinitionAndEnvironmentHeader.hs view
@@ -1,3 +1,1 @@ module MacroDefinitionAndEnvironment where--import qualified Axel.Parse.AST as AST
resources/new-project-template/Setup.hs view
@@ -1,3 +1,4 @@-import Distribution.Simple(defaultMain)+import Distribution.Simple (defaultMain)+ main :: (IO ())-main = defaultMain+main = defaultMain
resources/new-project-template/app/Main.hs view
@@ -1,4 +1,4 @@-module Main where import Lib+ main :: (IO ())-main = someFunc+main = someFunc
resources/new-project-template/src/Lib.hs view
@@ -1,3 +1,2 @@-module Lib where someFunc :: (IO ())-someFunc = (putStrLn "someFunc")+someFunc = (putStrLn "someFunc")
resources/new-project-template/test/Spec.hs view
@@ -1,2 +1,2 @@ main :: (IO ())-main = (putStrLn "Test suite not yet implemented")+main = (putStrLn "Test suite not yet implemented")
+ scripts/format.sh view
@@ -0,0 +1,4 @@+#!/bin/zsh+for f in {app,src,test}/**/*.hs; do+ hindent "$f"+done
src/Axel/AST.hs view
@@ -9,7 +9,6 @@ module Axel.AST where -import Axel.Error (fatal) import Axel.Utils.Display ( Bracket(DoubleQuotes, Parentheses, SingleQuotes, SquareBrackets) , Delimiter(Commas, Newlines, Pipes, Spaces)@@ -19,13 +18,13 @@ , renderPragma , surround )-import Axel.Utils.Recursion (Recursive(bottomUpFmap, bottomUpTraverse))+import Axel.Utils.Recursion+ ( Recursive(bottomUpFmap, bottomUpTraverse, topDownFmap)+ ) import Control.Arrow ((***)) import Control.Lens.Operators ((%~), (^.)) import Control.Lens.TH (makeFieldsNoPrefix)-import Control.Lens.Tuple (_1, _2)- import Data.Function ((&)) import Data.Semigroup ((<>)) @@ -37,21 +36,21 @@ data CaseBlock = CaseBlock { _expr :: Expression , _matches :: [(Expression, Expression)]- } deriving (Eq)+ } deriving (Eq, Show) data FunctionApplication = FunctionApplication { _function :: Expression , _arguments :: [Expression]- } deriving (Eq)+ } deriving (Eq, Show) newtype TopLevel = TopLevel { _statements :: [Statement]- } deriving (Eq)+ } deriving (Eq, Show) data TypeDefinition = ProperType Identifier | TypeConstructor FunctionApplication- deriving (Eq)+ deriving (Eq, Show) instance ToHaskell TypeDefinition where toHaskell :: TypeDefinition -> String@@ -61,27 +60,19 @@ data DataDeclaration = DataDeclaration { _typeDefinition :: TypeDefinition , _constructors :: [FunctionApplication]- } deriving (Eq)--newtype ArgumentList =- ArgumentList [Expression]- deriving (Eq)--instance ToHaskell ArgumentList where- toHaskell :: ArgumentList -> String- toHaskell (ArgumentList arguments) = delimit Spaces $ map toHaskell arguments+ } deriving (Eq, Show) data FunctionDefinition = FunctionDefinition { _name :: Identifier- , _typeSignature :: FunctionApplication- , _definitions :: [(ArgumentList, Expression)]- } deriving (Eq)+ , _arguments :: [Expression]+ , _body :: Expression+ } deriving (Eq, Show) data Import = ImportItem Identifier | ImportType Identifier [Identifier]- deriving (Eq)+ deriving (Eq, Show) instance ToHaskell Import where toHaskell :: Import -> String@@ -95,7 +86,7 @@ data ImportSpecification = ImportAll | ImportOnly [Import]- deriving (Eq)+ deriving (Eq, Show) instance ToHaskell ImportSpecification where toHaskell :: ImportSpecification -> String@@ -106,42 +97,46 @@ data Lambda = Lambda { _arguments :: [Expression] , _body :: Expression- } deriving (Eq)--newtype LanguagePragma = LanguagePragma- { _language :: Identifier- } deriving (Eq)+ } deriving (Eq, Show) data LetBlock = LetBlock { _bindings :: [(Expression, Expression)] , _body :: Expression- } deriving (Eq)+ } deriving (Eq, Show) -data MacroDefinition = MacroDefinition- { _name :: Identifier- , _definitions :: [(ArgumentList, Expression)]- } deriving (Eq)+newtype MacroDefinition = MacroDefinition+ { _functionDefinition :: FunctionDefinition+ } deriving (Eq, Show) +newtype Pragma = Pragma+ { _pragmaSpecification :: String+ } deriving (Eq, Show)+ data QualifiedImport = QualifiedImport { _moduleName :: Identifier , _alias :: Identifier , _imports :: ImportSpecification- } deriving (Eq)+ } deriving (Eq, Show) data RestrictedImport = RestrictedImport { _moduleName :: Identifier , _imports :: ImportSpecification- } deriving (Eq)+ } deriving (Eq, Show) data TypeclassInstance = TypeclassInstance { _instanceName :: Expression , _definitions :: [FunctionDefinition]- } deriving (Eq)+ } deriving (Eq, Show) +data TypeSignature = TypeSignature+ { _name :: Identifier+ , _typeDefinition :: Expression+ } deriving (Eq, Show)+ data TypeSynonym = TypeSynonym { _alias :: Expression , _definition :: Expression- } deriving (Eq)+ } deriving (Eq, Show) data Expression = ECaseBlock CaseBlock@@ -151,7 +146,7 @@ | ELambda Lambda | ELetBlock LetBlock | ELiteral Literal- deriving (Eq)+ deriving (Eq, Show) instance ToHaskell Expression where toHaskell :: Expression -> String@@ -169,43 +164,42 @@ data Literal = LChar Char | LInt Int- | LList [Expression] | LString String- deriving (Eq)+ deriving (Eq, Show) instance ToHaskell Literal where toHaskell :: Literal -> String toHaskell (LChar x) = surround SingleQuotes [x] toHaskell (LInt x) = show x- toHaskell (LList xs) =- surround SquareBrackets $ delimit Commas $ map toHaskell xs toHaskell (LString x) = surround DoubleQuotes x data Statement = SDataDeclaration DataDeclaration | SFunctionDefinition FunctionDefinition- | SLanguagePragma LanguagePragma | SMacroDefinition MacroDefinition | SModuleDeclaration Identifier+ | SPragma Pragma | SQualifiedImport QualifiedImport | SRestrictedImport RestrictedImport | STopLevel TopLevel | STypeclassInstance TypeclassInstance+ | STypeSignature TypeSignature | STypeSynonym TypeSynonym | SUnrestrictedImport Identifier- deriving (Eq)+ deriving (Eq, Show) instance ToHaskell Statement where toHaskell :: Statement -> String toHaskell (SDataDeclaration x) = toHaskell x toHaskell (SFunctionDefinition x) = toHaskell x- toHaskell (SLanguagePragma x) = toHaskell x+ toHaskell (SPragma x) = toHaskell x toHaskell (SMacroDefinition x) = toHaskell x toHaskell (SModuleDeclaration x) = "module " <> x <> " where" toHaskell (SQualifiedImport x) = toHaskell x toHaskell (SRestrictedImport x) = toHaskell x toHaskell (STopLevel xs) = toHaskell xs toHaskell (STypeclassInstance x) = toHaskell x+ toHaskell (STypeSignature x) = toHaskell x toHaskell (STypeSynonym x) = toHaskell x toHaskell (SUnrestrictedImport x) = "import " <> x @@ -221,12 +215,12 @@ makeFieldsNoPrefix ''Lambda -makeFieldsNoPrefix ''LanguagePragma- makeFieldsNoPrefix ''LetBlock makeFieldsNoPrefix ''MacroDefinition +makeFieldsNoPrefix ''Pragma+ makeFieldsNoPrefix ''QualifiedImport makeFieldsNoPrefix ''RestrictedImport@@ -235,6 +229,8 @@ makeFieldsNoPrefix ''TypeclassInstance +makeFieldsNoPrefix ''TypeSignature+ makeFieldsNoPrefix ''TypeSynonym instance ToHaskell CaseBlock where@@ -258,20 +254,19 @@ toHaskell (functionApplication ^. function) <> " " <> delimit Spaces (map toHaskell $ functionApplication ^. arguments) -functionDefinitionToHaskell ::- Identifier -> (ArgumentList, Expression) -> String-functionDefinitionToHaskell functionName (pattern', definitionBody) =- functionName <> " " <> toHaskell pattern' <> " = " <> toHaskell definitionBody+instance ToHaskell TypeSignature where+ toHaskell :: TypeSignature -> String+ toHaskell typeSignature =+ toHaskell (EIdentifier (typeSignature ^. name)) <> " :: " <>+ toHaskell (typeSignature ^. typeDefinition) instance ToHaskell FunctionDefinition where toHaskell :: FunctionDefinition -> String- toHaskell functionDefinition =- delimit Newlines $- (functionDefinition ^. name <> " :: " <>- toHaskell (functionDefinition ^. typeSignature)) :- map- (functionDefinitionToHaskell $ functionDefinition ^. name)- (functionDefinition ^. definitions)+ toHaskell fnDef =+ toHaskell (EIdentifier (fnDef ^. name)) <> " " <>+ delimit Spaces (map toHaskell (fnDef ^. arguments)) <>+ " = " <>+ toHaskell (fnDef ^. body) instance ToHaskell DataDeclaration where toHaskell :: DataDeclaration -> String@@ -291,10 +286,9 @@ "\\" <> delimit Spaces (map toHaskell (lambda ^. arguments)) <> " -> " <> toHaskell (lambda ^. body) -instance ToHaskell LanguagePragma where- toHaskell :: LanguagePragma -> String- toHaskell languagePragma =- renderPragma $ "LANGUAGE " <> languagePragma ^. language+instance ToHaskell Pragma where+ toHaskell :: Pragma -> String+ toHaskell pragma = renderPragma (pragma ^. pragmaSpecification) instance ToHaskell LetBlock where toHaskell :: LetBlock -> String@@ -309,12 +303,7 @@ instance ToHaskell MacroDefinition where toHaskell :: MacroDefinition -> String- toHaskell macroDefinition =- delimit Newlines $- (macroDefinition ^. name <> " :: [AST.Expression] -> IO [AST.Expression]") :- map- (functionDefinitionToHaskell $ macroDefinition ^. name)- (macroDefinition ^. definitions)+ toHaskell macroDefinition = toHaskell (macroDefinition ^. functionDefinition) instance ToHaskell QualifiedImport where toHaskell :: QualifiedImport -> String@@ -352,29 +341,51 @@ case x of ECaseBlock caseBlock -> ECaseBlock $- caseBlock & expr %~ bottomUpFmap f & matches %~- map (bottomUpFmap f *** bottomUpFmap f)- EEmptySExpression -> f x+ caseBlock & expr %~ bottomUpFmap f &+ matches %~ map (bottomUpFmap f *** bottomUpFmap f)+ EEmptySExpression -> x EFunctionApplication functionApplication -> EFunctionApplication $- functionApplication & function %~ bottomUpFmap f & arguments %~- map (bottomUpFmap f)+ 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 ((_1 %~ bottomUpFmap f) . (_2 %~ bottomUpFmap f)) &- body %~- bottomUpFmap f+ letBlock & bindings %~ map (bottomUpFmap f *** bottomUpFmap f) &+ body %~ bottomUpFmap f ELiteral literal -> case literal of LChar _ -> x LInt _ -> x- LList exprs -> ELiteral (LList $ map (bottomUpFmap f) exprs) LString _ -> 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+ 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 bottomUpTraverse :: (Monad m) => (Expression -> m Expression) -> Expression -> m Expression bottomUpTraverse f x =@@ -408,42 +419,4 @@ case literal of LChar _ -> pure x LInt _ -> pure x- LList exprs ->- ELiteral . LList <$> traverse (bottomUpTraverse f) exprs LString _ -> pure x--extractNameFromDefinition :: Statement -> Maybe Identifier-extractNameFromDefinition (SDataDeclaration dataDeclaration) =- Just $- case dataDeclaration ^. typeDefinition of- ProperType typeName -> typeName- TypeConstructor fnApp ->- case fnApp ^. function of- ELiteral (LString typeName) -> typeName- _ -> fatal "extractNameFromDefinition" "0001"-extractNameFromDefinition (SFunctionDefinition functionDefinition) =- Just $ functionDefinition ^. name-extractNameFromDefinition (SLanguagePragma _) = Nothing-extractNameFromDefinition (SMacroDefinition _) = Nothing-extractNameFromDefinition (SModuleDeclaration _) = Nothing-extractNameFromDefinition (SQualifiedImport _) = Nothing-extractNameFromDefinition (SRestrictedImport _) = Nothing-extractNameFromDefinition (STopLevel _) = Nothing-extractNameFromDefinition (STypeclassInstance typeclassInstance) =- case typeclassInstance ^. instanceName of- ELiteral (LString identifier) -> Just identifier- _ -> Nothing-extractNameFromDefinition (STypeSynonym typeSynonym) =- case typeSynonym ^. alias of- ELiteral (LString identifier) -> Just identifier- _ -> Nothing-extractNameFromDefinition (SUnrestrictedImport _) = Nothing--removeDefinitionsByName :: [String] -> [Statement] -> [Statement]-removeDefinitionsByName namesToRemove =- filter- (\statement ->- not $- case extractNameFromDefinition statement of- Just definitionName -> definitionName `elem` namesToRemove- Nothing -> False)
src/Axel/Denormalize.hs view
@@ -1,15 +1,14 @@ module Axel.Denormalize where import Axel.AST- ( ArgumentList(ArgumentList)- , Expression(ECaseBlock, EEmptySExpression, EFunctionApplication,+ ( Expression(ECaseBlock, EEmptySExpression, EFunctionApplication, EIdentifier, ELambda, ELetBlock, ELiteral) , Import(ImportItem, ImportType) , ImportSpecification(ImportAll, ImportOnly)- , Literal(LChar, LInt, LList, LString)- , Statement(SDataDeclaration, SFunctionDefinition, SLanguagePragma,- SMacroDefinition, SModuleDeclaration, SQualifiedImport,- SRestrictedImport, STopLevel, STypeSynonym, STypeclassInstance,+ , Literal(LChar, LInt, LString)+ , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,+ SModuleDeclaration, SPragma, SQualifiedImport, SRestrictedImport,+ STopLevel, STypeSignature, STypeSynonym, STypeclassInstance, SUnrestrictedImport) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor)@@ -22,14 +21,14 @@ , definitions , expr , function+ , functionDefinition , imports , instanceName- , language , matches , moduleName , name+ , pragmaSpecification , typeDefinition- , typeSignature ) import qualified Axel.Parse as Parse ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,@@ -46,23 +45,22 @@ Parse.SExpression [denormalizeExpression pat, denormalizeExpression res]) (caseBlock ^. matches)- in Parse.SExpression $- Parse.Symbol "case" :- denormalizeExpression (caseBlock ^. expr) : denormalizedCases+ in Parse.SExpression $ Parse.Symbol "case" :+ denormalizeExpression (caseBlock ^. expr) :+ denormalizedCases denormalizeExpression EEmptySExpression = Parse.SExpression [] denormalizeExpression (EFunctionApplication functionApplication) =- Parse.SExpression $- denormalizeExpression (functionApplication ^. function) :+ Parse.SExpression $ denormalizeExpression (functionApplication ^. function) : map denormalizeExpression (functionApplication ^. arguments) denormalizeExpression (EIdentifier x) = Parse.Symbol x denormalizeExpression (ELambda lambda) = let denormalizedArguments = Parse.SExpression $ map denormalizeExpression (lambda ^. arguments)- in Parse.SExpression- [ Parse.Symbol "fn"- , denormalizedArguments- , denormalizeExpression (lambda ^. body)- ]+ in Parse.SExpression+ [ Parse.Symbol "\\"+ , denormalizedArguments+ , denormalizeExpression (lambda ^. body)+ ] denormalizeExpression (ELetBlock letBlock) = let denormalizedBindings = Parse.SExpression $@@ -71,26 +69,17 @@ Parse.SExpression [denormalizeExpression var, denormalizeExpression val]) (letBlock ^. bindings)- in Parse.SExpression- [ Parse.Symbol "let"- , denormalizedBindings- , denormalizeExpression (letBlock ^. body)- ]+ in Parse.SExpression+ [ Parse.Symbol "let"+ , denormalizedBindings+ , denormalizeExpression (letBlock ^. body)+ ] denormalizeExpression (ELiteral x) = case x of LChar char -> Parse.LiteralChar char LInt int -> Parse.LiteralInt int- LList list ->- Parse.SExpression $ Parse.Symbol "list" : map denormalizeExpression list LString string -> Parse.LiteralString string -denormalizeBinding :: (ArgumentList, Expression) -> Parse.Expression-denormalizeBinding (ArgumentList argumentList, expression) =- Parse.SExpression- [ Parse.SExpression $ map denormalizeExpression argumentList- , denormalizeExpression expression- ]- denormalizeImportSpecification :: ImportSpecification -> Parse.Expression denormalizeImportSpecification ImportAll = Parse.Symbol "all" denormalizeImportSpecification (ImportOnly importList) =@@ -107,29 +96,29 @@ TypeConstructor typeConstructor -> denormalizeExpression $ EFunctionApplication typeConstructor ProperType properType -> Parse.Symbol properType- in Parse.SExpression- [ Parse.Symbol "data"- , denormalizedTypeDefinition- , Parse.SExpression $+ in Parse.SExpression+ (Parse.Symbol "data" : denormalizedTypeDefinition : map (denormalizeExpression . EFunctionApplication)- (dataDeclaration ^. constructors)- ]-denormalizeStatement (SFunctionDefinition functionDefinition) =- Parse.SExpression $- Parse.Symbol "=" :- Parse.Symbol (functionDefinition ^. name) :- denormalizeExpression- (EFunctionApplication (functionDefinition ^. typeSignature)) :- map denormalizeBinding (functionDefinition ^. definitions)-denormalizeStatement (SLanguagePragma languagePragma) =+ (dataDeclaration ^. constructors))+denormalizeStatement (SFunctionDefinition fnDef) = Parse.SExpression- [Parse.Symbol "language", Parse.Symbol $ languagePragma ^. language]-denormalizeStatement (SMacroDefinition macroDefinition) =- Parse.SExpression $- Parse.Symbol "defmacro" :- Parse.Symbol (macroDefinition ^. name) :- map denormalizeBinding (macroDefinition ^. definitions)+ [ Parse.Symbol "="+ , Parse.Symbol (fnDef ^. name)+ , Parse.SExpression (map denormalizeExpression (fnDef ^. arguments))+ , denormalizeExpression (fnDef ^. body)+ ]+denormalizeStatement (SPragma pragma) =+ Parse.SExpression+ [Parse.Symbol "pragma", Parse.LiteralString (pragma ^. pragmaSpecification)]+denormalizeStatement (SMacroDefinition macroDef) =+ Parse.SExpression+ [ Parse.Symbol "macro"+ , Parse.Symbol (macroDef ^. functionDefinition . name)+ , Parse.SExpression+ (map denormalizeExpression (macroDef ^. functionDefinition . arguments))+ , denormalizeExpression (macroDef ^. functionDefinition . body)+ ] denormalizeStatement (SModuleDeclaration identifier) = Parse.SExpression [Parse.Symbol "module", Parse.Symbol identifier] denormalizeStatement (SQualifiedImport qualifiedImport) =@@ -149,12 +138,16 @@ Parse.SExpression $ Parse.Symbol "begin" : map denormalizeStatement statements denormalizeStatement (STypeclassInstance typeclassInstance) = Parse.SExpression- [ Parse.Symbol "instance"- , denormalizeExpression (typeclassInstance ^. instanceName)- , Parse.SExpression $- map- (denormalizeStatement . SFunctionDefinition)- (typeclassInstance ^. definitions)+ (Parse.Symbol "instance" :+ denormalizeExpression (typeclassInstance ^. instanceName) :+ map+ (denormalizeStatement . SFunctionDefinition)+ (typeclassInstance ^. definitions))+denormalizeStatement (STypeSignature typeSig) =+ Parse.SExpression+ [ Parse.Symbol "::"+ , Parse.Symbol (typeSig ^. name)+ , denormalizeExpression (typeSig ^. typeDefinition) ] denormalizeStatement (STypeSynonym typeSynonym) = Parse.SExpression
− src/Axel/Entry.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}--module Axel.Entry where--import Axel.AST (ToHaskell(toHaskell))-import Axel.Error (Error)-import Axel.GHC (runWithGHC)-import Axel.Macros (exhaustivelyExpandMacros, stripMacroDefinitions)-import Axel.Normalize (normalizeStatement)-import Axel.Parse (Expression(Symbol), parseSource)-import Axel.Utils.Directory (withTempDirectory)-import Axel.Utils.Recursion (Recursive(bottomUpFmap))-import Axel.Utils.Resources (readResource)-import qualified Axel.Utils.Resources as Res (astDefinition)--import Control.Lens.Operators ((.~))-import Control.Monad.Except (MonadError, runExceptT, throwError)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Control (MonadBaseControl)--import Data.Maybe (fromMaybe)-import Data.Semigroup ((<>))-import qualified Data.Text as T (isSuffixOf, pack)--import System.FilePath ((</>), stripExtension)-import System.FilePath.Lens (directory)-import qualified System.IO.Strict as S (readFile)--convertList :: Expression -> Expression-convertList =- bottomUpFmap $ \case- Symbol "List" -> Symbol "[]"- x -> x--convertUnit :: Expression -> Expression-convertUnit =- bottomUpFmap $ \case- Symbol "Unit" -> Symbol "()"- Symbol "unit" -> Symbol "()"- x -> x--transpileSource ::- (MonadBaseControl IO m, MonadError Error m, MonadIO m)- => String- -> m String-transpileSource source =- toHaskell . stripMacroDefinitions <$>- (parseSource source >>= exhaustivelyExpandMacros . convertList . convertUnit >>=- normalizeStatement)--axelPathToHaskellPath :: FilePath -> FilePath-axelPathToHaskellPath axelPath =- let basePath =- if ".axel" `T.isSuffixOf` T.pack axelPath- then fromMaybe axelPath $ stripExtension ".axel" axelPath- else axelPath- in basePath <> ".hs"---- TODO Switch this to `(MonadError Error m, MonadIO m)` and do the error check in `evalFile`.-transpileFile :: FilePath -> FilePath -> IO ()-transpileFile path newPath = do- fileContents <- S.readFile path- result <- runExceptT $ transpileSource fileContents- case result of- Left err -> throwError $ userError $ show err- Right newContents -> writeFile newPath newContents---- Transpile a file in place.-transpileFile' :: FilePath -> IO FilePath-transpileFile' path = do- let newPath = axelPathToHaskellPath path- transpileFile path newPath- pure newPath--evalFile :: FilePath -> IO ()-evalFile path =- withTempDirectory $ \tempDirectoryPath -> do- let astDefinitionPath = tempDirectoryPath </> "Axel.hs"- readResource Res.astDefinition >>= writeFile astDefinitionPath- let newPath = directory .~ tempDirectoryPath $ axelPathToHaskellPath path- transpileFile path newPath- evalResult <- runExceptT $ runWithGHC newPath- either (throwError . userError . show) putStr evalResult
src/Axel/Error.hs view
@@ -1,26 +1,45 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-} module Axel.Error where import Axel.Parse.AST (Expression, toAxel) -import Data.Semigroup ((<>))+import Control.Monad.Except (ExceptT, MonadError(throwError), runExceptT) -import Text.Parsec (ParseError)+import Data.Semigroup ((<>)) data Error- = MacroError String+ = EvalError String+ | MacroError String | NormalizeError String [Expression]- | ParseError ParseError+ | 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) = show err+ show (ParseError err) = err+ show (ProjectError err) = err fatal :: String -> String -> a fatal context message = error $ "[FATAL] " <> context <> " - " <> message++toIO :: (MonadError IOError m) => ExceptT Error m a -> m a+toIO f = do+ result :: Either Error a <- runExceptT f+ case result of+ Left err -> throwError $ userError $ show err+ Right x -> pure x++mapError :: (MonadError e' m) => ExceptT e m a -> (e -> e') -> m a+x `mapError` f =+ runExceptT x >>= \case+ Left err -> throwError (f err)+ Right res -> pure res
− src/Axel/Eval.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Axel.Eval where--import Axel.Error (Error(MacroError))-import Axel.GHC (buildWithGHC, runWithGHC)-import Axel.Utils.Directory (withCurrentDirectoryLifted, withTempDirectory)--import Control.Monad.Except (MonadError, throwError)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Control (MonadBaseControl)--import System.Directory (createDirectoryIfMissing)-import System.FilePath ((</>))-import System.IO (writeFile)--execInterpreter :: (MonadError Error m, MonadIO m) => FilePath -> m String-execInterpreter scaffoldFilePath = do- debugResult <- liftIO $ buildWithGHC scaffoldFilePath- case debugResult of- Right _ -> runWithGHC scaffoldFilePath- Left stderr -> throwError $ MacroError stderr--evalMacro ::- (MonadBaseControl IO m, MonadError Error m, MonadIO m)- => String- -> String- -> String- -> m String-evalMacro astDefinition scaffold macroDefinitionAndEnvironment =- withTempDirectory $ \directoryName ->- withCurrentDirectoryLifted directoryName $ do- let astDirectoryPath = "Axel" </> "Parse"- let macroDefinitionAndEnvironmentFileName =- "MacroDefinitionAndEnvironment.hs"- let scaffoldFileName = "Scaffold.hs"- liftIO $ createDirectoryIfMissing True astDirectoryPath- liftIO $ writeFile (astDirectoryPath </> "AST.hs") astDefinition- liftIO $- writeFile- macroDefinitionAndEnvironmentFileName- macroDefinitionAndEnvironment- liftIO $ writeFile scaffoldFileName scaffold- execInterpreter scaffoldFileName
− src/Axel/GHC.hs
@@ -1,35 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleContexts #-}--module Axel.GHC where--import Axel.Error (Error(MacroError))--import Control.Monad.Except (MonadError, throwError)-import Control.Monad.IO.Class (MonadIO, liftIO)--import System.Exit (ExitCode(ExitFailure, ExitSuccess))-import System.Process (readProcessWithExitCode)---- TODO Rename to `ghcCompile`-buildWithGHC :: (MonadIO m) => FilePath -> m (Either String String)-buildWithGHC filePath = do- (exitCode, stdout, stderr) <-- liftIO $- readProcessWithExitCode- "stack"- ["--resolver", "lts-12.0", "ghc", "--", "-v0", "-ddump-json", filePath]- ""- pure $- case exitCode of- ExitSuccess -> Right stdout- ExitFailure _ -> Left stderr---- TODO Rename to `ghcInterpret`-runWithGHC :: (MonadError Error m, MonadIO m) => FilePath -> m String-runWithGHC filePath = do- (exitCode, stdout, stderr) <-- liftIO $ readProcessWithExitCode "stack" ["runghc", filePath] ""- case exitCode of- ExitSuccess -> pure stdout- ExitFailure _ -> throwError $ MacroError stderr
+ src/Axel/Haskell/File.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Axel.Haskell.File where++import Prelude hiding (putStr, putStrLn)++import Axel.AST (ToHaskell(toHaskell))+import Axel.Error (Error(EvalError), mapError)+import Axel.Haskell.GHC (ghcInterpret)+import Axel.Haskell.Prettify (prettifyHaskell)+import Axel.Macros (exhaustivelyExpandMacros, stripMacroDefinitions)+import Axel.Monad.Console (MonadConsole(putStr), putStrLn)+import Axel.Monad.FileSystem (MonadFileSystem)+import qualified Axel.Monad.FileSystem as FS+ ( MonadFileSystem(readFile, writeFile)+ , withTemporaryDirectory+ )+import Axel.Monad.Process (MonadProcess)+import Axel.Monad.Resource (MonadResource, readResource)+import qualified Axel.Monad.Resource as Res (astDefinition)+import Axel.Normalize (normalizeStatement)+import Axel.Parse (Expression(Symbol), parseSource)+import Axel.Utils.Recursion (Recursive(bottomUpFmap))++import Control.Lens.Operators ((.~))+import Control.Monad.Except (MonadError)++import Data.Maybe (fromMaybe)+import Data.Semigroup ((<>))+import qualified Data.Text as T (isSuffixOf, pack)++import System.FilePath ((</>), stripExtension, takeFileName)+import System.FilePath.Lens (directory)++convertList :: Expression -> Expression+convertList =+ bottomUpFmap $ \case+ Symbol "List" -> Symbol "[]"+ x -> x++convertUnit :: Expression -> Expression+convertUnit =+ bottomUpFmap $ \case+ Symbol "Unit" -> Symbol "()"+ Symbol "unit" -> Symbol "()"+ x -> x++transpileSource ::+ (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m)+ => String+ -> m String+transpileSource source =+ prettifyHaskell . toHaskell . stripMacroDefinitions <$>+ (parseSource source >>= exhaustivelyExpandMacros . convertList . convertUnit >>=+ normalizeStatement)++axelPathToHaskellPath :: FilePath -> FilePath+axelPathToHaskellPath axelPath =+ let basePath =+ if ".axel" `T.isSuffixOf` T.pack axelPath+ then fromMaybe axelPath $ stripExtension ".axel" axelPath+ else axelPath+ in basePath <> ".hs"++transpileFile ::+ (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m)+ => FilePath+ -> FilePath+ -> m ()+transpileFile path newPath = do+ fileContents <- FS.readFile path+ newContents <- transpileSource fileContents+ FS.writeFile newPath newContents++-- | Transpile a file in place.+transpileFile' ::+ (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m)+ => FilePath+ -> m FilePath+transpileFile' path = do+ let newPath = axelPathToHaskellPath path+ transpileFile path newPath+ pure newPath++evalFile ::+ ( MonadConsole m+ , MonadError Error m+ , MonadFileSystem m+ , MonadProcess m+ , MonadResource m+ )+ => FilePath+ -> m ()+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 <> "...")+ output <- ghcInterpret newPath `mapError` EvalError+ putStr output
+ src/Axel/Haskell/GHC.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Haskell.GHC where++import Axel.Haskell.Stack (axelStackageId, stackageResolverWithAxel)+import Axel.Monad.Process (MonadProcess(runProcess))++import Control.Monad.Except (MonadError, throwError)++import System.Exit (ExitCode(ExitFailure, ExitSuccess))++ghcCompile :: (MonadError String m, MonadProcess m) => FilePath -> m String+ghcCompile filePath = do+ (exitCode, stdout, stderr) <-+ runProcess+ "stack"+ [ "--resolver"+ , stackageResolverWithAxel+ , "ghc"+ , "--"+ , "-v0"+ , "-ddump-json"+ , filePath+ ]+ ""+ case exitCode of+ ExitSuccess -> pure stdout+ ExitFailure _ -> throwError stderr++ghcInterpret :: (MonadError String m, MonadProcess m) => FilePath -> m String+ghcInterpret filePath = do+ (exitCode, stdout, stderr) <-+ runProcess+ "stack"+ [ "--resolver"+ , stackageResolverWithAxel+ , "runghc"+ , "--package"+ , axelStackageId+ , "--"+ , filePath+ ]+ ""+ case exitCode of+ ExitSuccess -> pure stdout+ ExitFailure _ -> throwError stderr
+ src/Axel/Haskell/Prettify.hs view
@@ -0,0 +1,14 @@+{-# 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
@@ -0,0 +1,75 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Haskell.Project where++import Axel.Error (Error)+import Axel.Haskell.File (transpileFile')+import Axel.Haskell.Stack+ ( addStackDependency+ , axelStackageSpecifier+ , buildStackProject+ , createStackProject+ , runStackProject+ )+import Axel.Monad.Console (MonadConsole)+import Axel.Monad.FileSystem+ ( MonadFileSystem(copyFile, getCurrentDirectory, removeFile)+ , getDirectoryContentsRec+ )+import Axel.Monad.Process (MonadProcess)+import Axel.Monad.Resource (MonadResource(getResourcePath), newProjectTemplate)++import Control.Monad.Except (MonadError)++import Data.Semigroup ((<>))+import qualified Data.Text as T (isSuffixOf, pack)++import System.FilePath ((</>))++type ProjectPath = FilePath++newProject ::+ (MonadFileSystem m, MonadProcess m, MonadResource m) => String -> m ()+newProject projectName = do+ createStackProject projectName+ addStackDependency axelStackageSpecifier projectName+ 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"]++transpileProject ::+ (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m)+ => m [FilePath]+transpileProject = do+ files <- getDirectoryContentsRec "."+ let axelFiles =+ filter (\filePath -> ".axel" `T.isSuffixOf` T.pack filePath) files+ mapM transpileFile' axelFiles++buildProject ::+ ( MonadConsole m+ , MonadError Error m+ , MonadFileSystem m+ , MonadProcess m+ , MonadResource m+ )+ => m ()+buildProject = do+ projectPath <- getCurrentDirectory+ hsPaths <- transpileProject+ buildStackProject projectPath+ mapM_ removeFile hsPaths++runProject ::+ (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m)+ => m ()+runProject = getCurrentDirectory >>= runStackProject
+ src/Axel/Haskell/Stack.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Haskell.Stack where++import Prelude hiding (putStrLn)++import Axel.Error (Error(ProjectError), fatal)+import Axel.Monad.Console (MonadConsole, putStrLn)+import Axel.Monad.FileSystem (MonadFileSystem)+import qualified Axel.Monad.FileSystem as FS+ ( MonadFileSystem(readFile, writeFile)+ , withCurrentDirectory+ )+import Axel.Monad.Process+ ( MonadProcess(runProcess, runProcessInheritingStreams)+ )++import Control.Lens.Operators ((%~))+import Control.Monad (void)+import Control.Monad.Except (MonadError, throwError)++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 Data.Vector (cons)+import Data.Version (showVersion)+import qualified Data.Yaml as Yaml (Value(String), decodeEither', encode)++import Paths_axel (version)++import System.Exit (ExitCode(ExitFailure, ExitSuccess))+import System.FilePath (takeFileName)++import Text.Regex.PCRE ((=~), getAllTextSubmatches)++type ProjectPath = FilePath++type StackageId = String++type StackageResolver = String++type Target = String++type Version = String++stackageResolverWithAxel :: StackageResolver+stackageResolverWithAxel = "nightly-2018-08-20"++axelStackageVersion :: Version+axelStackageVersion = showVersion version++axelStackageId :: StackageId+axelStackageId = "axel-" <> showVersion version++axelStackageSpecifier :: StackageId+axelStackageSpecifier = "axel ==" <> axelStackageVersion++getStackProjectTargets ::+ (Monad m, MonadFileSystem m, MonadProcess m) => ProjectPath -> m [Target]+getStackProjectTargets projectPath =+ FS.withCurrentDirectory projectPath $ do+ (_, _, stderr) <- runProcess "stack" ["ide", "targets"] ""+ pure $ lines stderr++addStackDependency :: (MonadFileSystem m) => StackageId -> ProjectPath -> m ()+addStackDependency dependencyId projectPath =+ FS.withCurrentDirectory projectPath $ do+ let packageConfigPath = "package.yaml"+ packageConfigContents <- FS.readFile packageConfigPath+ case Yaml.decodeEither' $ B.pack packageConfigContents of+ Right contents ->+ let newContents :: Yaml.Value =+ contents & key "dependencies" . _Array %~+ cons (Yaml.String $ T.pack dependencyId)+ encodedContents = B.unpack $ Yaml.encode newContents+ in FS.writeFile packageConfigPath encodedContents+ Left _ -> fatal "addStackDependency" "0001"++buildStackProject ::+ (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m)+ => ProjectPath+ -> m ()+buildStackProject projectPath = do+ putStrLn ("Building " <> takeFileName projectPath <> "...")+ result <-+ FS.withCurrentDirectory projectPath $ runProcess "stack" ["build"] ""+ case result of+ (ExitSuccess, _, _) -> pure ()+ (ExitFailure _, stdout, stderr) ->+ throwError $+ ProjectError+ ("Project failed to build.\n\nStdout:\n" <> stdout <> "\n\nStderr:\n" <>+ stderr)++createStackProject :: (MonadFileSystem m, MonadProcess m) => String -> m ()+createStackProject projectName = do+ void $ runProcess "stack" ["new", projectName, "new-template"] ""+ setStackageResolver projectName stackageResolverWithAxel++runStackProject ::+ (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m)+ => ProjectPath+ -> m ()+runStackProject projectPath = do+ targets <- getStackProjectTargets projectPath+ case findExeTargets targets of+ [target] -> do+ putStrLn ("Running " <> target <> "...")+ void $ runProcessInheritingStreams "stack" ["exec", target]+ _ ->+ throwError $ ProjectError "No executable target was unambiguously found!"+ where+ findExeTargets =+ foldl'+ (\acc target ->+ case getAllTextSubmatches $ target =~+ ("([^:]*):exe:([^:]*)" :: String) of+ [_fullMatch, _projectName, targetName] -> targetName : acc+ _ -> acc)+ []++setStackageResolver ::+ (MonadFileSystem m, MonadProcess m)+ => ProjectPath+ -> StackageResolver+ -> m ()+setStackageResolver projectPath resolver =+ void $ FS.withCurrentDirectory projectPath $+ runProcess "stack" ["config", "set", "resolver", resolver] ""
src/Axel/Macros.hs view
@@ -6,22 +6,40 @@ import Axel.AST ( Identifier , MacroDefinition- , Statement(SDataDeclaration, SFunctionDefinition, SLanguagePragma,- SMacroDefinition, SModuleDeclaration, SQualifiedImport,- SRestrictedImport, STopLevel, STypeSynonym, STypeclassInstance,+ , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,+ SModuleDeclaration, SPragma, SQualifiedImport, SRestrictedImport,+ STopLevel, STypeSignature, STypeSynonym, STypeclassInstance, SUnrestrictedImport) , ToHaskell(toHaskell)+ , functionDefinition , name , statements ) import Axel.Denormalize (denormalizeStatement) import Axel.Error (Error(MacroError))-import Axel.Eval (evalMacro)+import Axel.Haskell.GHC (ghcInterpret)+import Axel.Haskell.Prettify (prettifyHaskell)+import Axel.Monad.FileSystem (MonadFileSystem)+import qualified Axel.Monad.FileSystem as FS+ ( MonadFileSystem(createDirectoryIfMissing, writeFile)+ , withCurrentDirectory+ , withTemporaryDirectory+ )+import Axel.Monad.Process (MonadProcess)+import Axel.Monad.Resource (MonadResource, readResource)+import qualified Axel.Monad.Resource as Res+ ( astDefinition+ , macroDefinitionAndEnvironmentFooter+ , macroDefinitionAndEnvironmentHeader+ , macroScaffold+ ) import Axel.Normalize (normalizeStatement) import qualified Axel.Parse as Parse ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression, Symbol) , parseMultiple+ , programToTopLevelExpressions+ , topLevelExpressionsToProgram ) import Axel.Utils.Display (Delimiter(Newlines), delimit, isOperator) import Axel.Utils.Function (uncurry3)@@ -29,170 +47,179 @@ ( Recursive(bottomUpFmap, bottomUpTraverse) , exhaustM )-import Axel.Utils.Resources (readResource)-import qualified Axel.Utils.Resources as Res- ( astDefinition- , macroDefinitionAndEnvironmentHeader- , macroScaffold- ) import Axel.Utils.String (replace) +import Control.Lens.Cons (snoc) import Control.Lens.Operators ((%~), (^.)) import Control.Lens.Tuple (_1, _2) import Control.Monad (foldM)-import Control.Monad.Except (MonadError, catchError, throwError)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Except (MonadError, catchError, runExceptT, throwError) import Data.Function ((&))+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import qualified Data.List.NonEmpty as NE (head, toList) import Data.Semigroup ((<>)) +import System.FilePath ((</>))+ generateMacroProgram ::- (MonadBaseControl IO m, MonadError Error m, MonadIO m)- => MacroDefinition+ (MonadError Error m, MonadFileSystem m, MonadResource m)+ => NonEmpty MacroDefinition -> [Statement] -> [Parse.Expression] -> m (String, String, String)-generateMacroProgram macroDefinition environment applicationArguments = do- astDefinition <- liftIO $ readResource Res.astDefinition- scaffold <- liftIO getScaffold- macroDefinitionAndEnvironment <-- (<>) <$> liftIO (readResource Res.macroDefinitionAndEnvironmentHeader) <*>- getMacroDefinitionAndEnvironmentFooter- pure (astDefinition, scaffold, macroDefinitionAndEnvironment)+generateMacroProgram macroDefs env applicationArgs = do+ astDef <- readResource Res.astDefinition+ scaffold <- getScaffold+ macroDefAndEnv <- (<>) <$> getMacroDefAndEnvHeader <*> getMacroDefAndEnvFooter+ pure (astDef, scaffold, macroDefAndEnv) where- getMacroDefinitionAndEnvironmentFooter = do- hygenicMacroDefinition <-- replaceName- (macroDefinition ^. name)- newMacroName- (SMacroDefinition macroDefinition)- let source =- delimit Newlines $- map toHaskell (environment <> [hygenicMacroDefinition])- pure source- getScaffold =- let insertApplicationArguments =- let applicationArgumentsPlaceholder = "%%%ARGUMENTS%%%"- in replace- applicationArgumentsPlaceholder- (show applicationArguments)- insertDefinitionName =- let definitionNamePlaceholder = "%%%MACRO_NAME%%%"- in replace definitionNamePlaceholder newMacroName- in insertApplicationArguments . insertDefinitionName <$>- readResource Res.macroScaffold+ insertDefName =+ let defNamePlaceholder = "%%%MACRO_NAME%%%"+ in replace defNamePlaceholder newMacroName+ oldMacroName = NE.head macroDefs ^. functionDefinition . name newMacroName =- (macroDefinition ^. name) ++- if isOperator (macroDefinition ^. name)+ oldMacroName <>+ if isOperator oldMacroName then "%%%%%%%%%%" else "_AXEL_AUTOGENERATED_MACRO_DEFINITION"+ getMacroDefAndEnvHeader =+ insertDefName <$> readResource Res.macroDefinitionAndEnvironmentHeader+ getMacroDefAndEnvFooter = do+ hygenicMacroDefs <-+ traverse+ (replaceName oldMacroName newMacroName . SMacroDefinition)+ macroDefs+ let source =+ prettifyHaskell $ delimit Newlines $+ map toHaskell (env <> NE.toList hygenicMacroDefs)+ footer <-+ insertDefName <$> readResource Res.macroDefinitionAndEnvironmentFooter+ pure (unlines [source, footer])+ getScaffold :: (Monad m, MonadFileSystem m, MonadResource m) => m String+ getScaffold =+ let insertApplicationArgs =+ let applicationArgsPlaceholder = "%%%ARGUMENTS%%%"+ in replace applicationArgsPlaceholder (show applicationArgs)+ in prettifyHaskell . insertApplicationArgs . insertDefName <$>+ readResource Res.macroScaffold expansionPass ::- (MonadBaseControl IO m, MonadError Error m, MonadIO m)+ (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => Parse.Expression -> m Parse.Expression expansionPass programExpr =- stmtExprsToProgram . map denormalizeStatement <$>- expandMacros (programToTopLevelExprs programExpr)- where- programToTopLevelExprs :: Parse.Expression -> [Parse.Expression]- programToTopLevelExprs (Parse.SExpression (Parse.Symbol "begin":stmts)) =- stmts- programToTopLevelExprs _ =- error "programToTopLevelExprs must be passed a top-level program!"- stmtExprsToProgram :: [Parse.Expression] -> Parse.Expression- stmtExprsToProgram stmts = Parse.SExpression (Parse.Symbol "begin" : stmts)+ 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)+ exhaustivelyExpandMacros ::- (MonadBaseControl IO m, MonadError Error m, MonadIO m)+ (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => Parse.Expression -> m Parse.Expression exhaustivelyExpandMacros = exhaustM expansionPass --- TODO This needs heavy optimization.+isStatementNonconflicting :: Statement -> Bool+isStatementNonconflicting (SDataDeclaration _) = True+isStatementNonconflicting (SFunctionDefinition _) = True+isStatementNonconflicting (SPragma _) = True+isStatementNonconflicting (SMacroDefinition _) = True+isStatementNonconflicting (SModuleDeclaration _) = False+isStatementNonconflicting (SQualifiedImport _) = True+isStatementNonconflicting (SRestrictedImport _) = True+isStatementNonconflicting (STopLevel _) = False+isStatementNonconflicting (STypeclassInstance _) = True+isStatementNonconflicting (STypeSignature _) = True+isStatementNonconflicting (STypeSynonym _) = True+isStatementNonconflicting (SUnrestrictedImport _) = True+ expandMacros ::- (MonadBaseControl IO m, MonadError Error m, MonadIO m)+ (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m) => [Parse.Expression] -> m [Statement] expandMacros topLevelExprs = fst <$> foldM (\acc@(stmts, macroDefs) expr -> do- expandedExpr <- fullyExpandExpr stmts macroDefs expr- stmt <- normalizeStatement expandedExpr- pure $- case stmt of- SMacroDefinition macroDefinition ->- acc & _2 %~ (<> [macroDefinition])- _ ->- if isStmtNonconflicting stmt- then acc & _1 %~ (<> [stmt])- else acc)+ expandedExprs <- fullyExpandExpr stmts macroDefs expr+ foldM+ (\acc' expandedExpr -> do+ stmt <- normalizeStatement expandedExpr+ pure $ acc' &+ case stmt of+ SMacroDefinition macroDefinition ->+ _2 %~ flip snoc macroDefinition+ _ -> _1 %~ flip snoc stmt)+ acc+ expandedExprs) ([], []) topLevelExprs where- isStmtNonconflicting =- \case- SDataDeclaration _ -> True- SFunctionDefinition _ -> True- SLanguagePragma _ -> True- SMacroDefinition _ -> True- SModuleDeclaration _ -> False- SQualifiedImport _ -> True- SRestrictedImport _ -> True- STopLevel _ -> False- STypeclassInstance _ -> True- STypeSynonym _ -> True- SUnrestrictedImport _ -> True- fullyExpandExpr stmts macroDefs =- exhaustM $- bottomUpTraverse- (\case- Parse.SExpression xs ->- Parse.SExpression <$>- foldM- (\acc x ->- case x of- Parse.LiteralChar _ -> pure $ acc ++ [x]- Parse.LiteralInt _ -> pure $ acc ++ [x]- Parse.LiteralString _ -> pure $ acc ++ [x]- Parse.SExpression [] -> pure $ acc ++ [x]- Parse.SExpression (function:args) ->- lookupMacroDefinition macroDefs function >>= \case- Just macroDefinition ->- (acc ++) <$>- expandMacroApplication macroDefinition stmts args- Nothing -> pure $ acc ++ [x]- Parse.Symbol _ -> pure $ acc ++ [x])- []- xs- expr -> pure expr)+ fullyExpandExpr ::+ ( MonadError Error m+ , MonadFileSystem m+ , MonadProcess m+ , MonadResource m+ )+ => [Statement]+ -> [MacroDefinition]+ -> Parse.Expression+ -> m [Parse.Expression]+ fullyExpandExpr stmts allMacroDefs expr = do+ let program = Parse.topLevelExpressionsToProgram [expr]+ expandedExpr <-+ exhaustM+ (bottomUpTraverse+ (\case+ Parse.SExpression xs ->+ Parse.SExpression <$>+ foldM+ (\acc x ->+ case x of+ Parse.LiteralChar _ -> pure $ acc ++ [x]+ Parse.LiteralInt _ -> pure $ acc ++ [x]+ Parse.LiteralString _ -> pure $ acc ++ [x]+ Parse.SExpression [] -> pure $ acc ++ [x]+ Parse.SExpression (function:args) ->+ case lookupMacroDefinitions function allMacroDefs of+ Just macroDefs ->+ (acc ++) <$>+ expandMacroApplication+ macroDefs+ (filter isStatementNonconflicting stmts)+ args+ Nothing -> pure $ acc ++ [x]+ Parse.Symbol _ -> pure $ acc ++ [x])+ []+ xs+ x -> pure x))+ program+ pure $ Parse.programToTopLevelExpressions expandedExpr expandMacroApplication ::- (MonadBaseControl IO m, MonadError Error m, MonadIO m)- => MacroDefinition+ (MonadError Error m, MonadFileSystem m, MonadProcess m, MonadResource m)+ => NonEmpty MacroDefinition -> [Statement] -> [Parse.Expression] -> m [Parse.Expression]-expandMacroApplication macroDef auxEnv args = do- macroProgram <- generateMacroProgram macroDef auxEnv args+expandMacroApplication macroDefs auxEnv args = do+ macroProgram <- generateMacroProgram macroDefs auxEnv args newSource <- uncurry3 evalMacro macroProgram Parse.parseMultiple newSource -lookupMacroDefinition ::- (MonadError Error m)- => [MacroDefinition]- -> Parse.Expression- -> m (Maybe MacroDefinition)-lookupMacroDefinition macroDefs identifierExpr =- case filter (`isMacroBeingCalled` identifierExpr) macroDefs of- [] -> pure Nothing- [macroDef] -> pure $ Just macroDef- macroDef:_ ->- throwError- (MacroError $- "Multiple macro definitions named: `" <> macroDef ^. name <> "`!")+lookupMacroDefinitions ::+ Parse.Expression -> [MacroDefinition] -> Maybe (NonEmpty MacroDefinition)+lookupMacroDefinitions identifierExpr =+ nonEmpty . filter (`isMacroBeingCalled` identifierExpr) isMacroBeingCalled :: MacroDefinition -> Parse.Expression -> Bool isMacroBeingCalled macroDef identifierExpr =@@ -201,7 +228,8 @@ Parse.LiteralInt _ -> False Parse.LiteralString _ -> False Parse.SExpression _ -> False- Parse.Symbol identifier -> macroDef ^. name == identifier+ Parse.Symbol identifier ->+ macroDef ^. functionDefinition . name == identifier stripMacroDefinitions :: Statement -> Statement stripMacroDefinitions =@@ -235,3 +263,30 @@ then newName else identifier _ -> expr++evalMacro ::+ (MonadError Error m, MonadFileSystem m, MonadProcess m)+ => String+ -> String+ -> String+ -> m 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+ runExceptT (ghcInterpret scaffoldFileName) >>= \case+ Left err ->+ throwError $+ MacroError+ ("Temporary directory: " <> directoryName <> "\n\n" <> "Error:\n" <>+ err)+ Right res -> pure res
+ src/Axel/Monad/Console.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Monad.Console where++import Prelude hiding (putStr)+import qualified Prelude++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Identity (IdentityT)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.Cont (ContT)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST)+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT)+import qualified Control.Monad.Trans.State.Strict as StrictState (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT)+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT)++class (Monad m) =>+ MonadConsole m+ where+ putStr :: String -> m ()+ default putStr :: (MonadTrans t, MonadConsole m', m ~ t m') =>+ String -> m ()+ putStr = lift . putStr++instance (MonadConsole m) => MonadConsole (ContT r m)++instance (MonadConsole m) => MonadConsole (ExceptT e m)++instance (MonadConsole m) => MonadConsole (IdentityT m)++instance (MonadConsole m) => MonadConsole (MaybeT m)++instance (MonadConsole m) => MonadConsole (ReaderT r m)++instance (Monoid w, MonadConsole m) => MonadConsole (LazyRWS.RWST r w s m)++instance (Monoid w, MonadConsole m) =>+ MonadConsole (StrictRWS.RWST r w s m)++instance (MonadConsole m) => MonadConsole (LazyState.StateT s m)++instance (MonadConsole m) => MonadConsole (StrictState.StateT s m)++instance (Monoid w, MonadConsole m) =>+ MonadConsole (LazyWriter.WriterT w m)++instance (Monoid w, MonadConsole m) =>+ MonadConsole (StrictWriter.WriterT w m)++instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadConsole m where+ putStr :: String -> m ()+ putStr = liftIO . Prelude.putStr++putStrLn :: (MonadConsole m) => String -> m ()+putStrLn str = putStr (str <> "\n")
+ src/Axel/Monad/FileSystem.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Monad.FileSystem where++import Prelude hiding (readFile, writeFile)+import qualified Prelude (readFile, writeFile)++import Control.Monad (forM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Identity (IdentityT)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.Cont (ContT)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST)+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT)+import qualified Control.Monad.Trans.State.Strict as StrictState (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT)+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT)++import qualified System.Directory+ ( copyFile+ , createDirectoryIfMissing+ , doesDirectoryExist+ , getCurrentDirectory+ , getDirectoryContents+ , getTemporaryDirectory+ , removeFile+ , setCurrentDirectory+ )+import System.FilePath ((</>))+import qualified System.IO.Strict as S (readFile)++class (Monad m) =>+ MonadFileSystem m+ where+ copyFile :: FilePath -> FilePath -> m ()+ default copyFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') =>+ FilePath -> FilePath -> m ()+ copyFile src dest = lift $ copyFile src dest+ createDirectoryIfMissing :: Bool -> FilePath -> m ()+ default createDirectoryIfMissing :: ( MonadTrans t+ , MonadFileSystem m'+ , m ~ t m'+ ) =>+ Bool -> FilePath -> m ()+ createDirectoryIfMissing createParents path =+ lift $ createDirectoryIfMissing createParents path+ doesDirectoryExist :: FilePath -> m Bool+ default doesDirectoryExist :: (MonadTrans t, MonadFileSystem m', m ~ t m') =>+ FilePath -> m Bool+ doesDirectoryExist = lift . doesDirectoryExist+ getCurrentDirectory :: m FilePath+ default getCurrentDirectory :: (MonadTrans t, MonadFileSystem m', m ~ t m') =>+ m FilePath+ getCurrentDirectory = lift getCurrentDirectory+ getDirectoryContents :: FilePath -> m [FilePath]+ default getDirectoryContents :: (MonadTrans t, MonadFileSystem m', m ~ t m') =>+ FilePath -> m [FilePath]+ getDirectoryContents = lift . getDirectoryContents+ getTemporaryDirectory :: m FilePath+ default getTemporaryDirectory :: (MonadTrans t, MonadFileSystem m', m ~ t m') =>+ m FilePath+ getTemporaryDirectory = lift getTemporaryDirectory+ readFile :: FilePath -> m String+ default readFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') =>+ FilePath -> m String+ readFile = lift . readFile+ removeFile :: FilePath -> m ()+ default removeFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') =>+ FilePath -> m ()+ removeFile = lift . removeFile+ setCurrentDirectory :: FilePath -> m ()+ default setCurrentDirectory :: (MonadTrans t, MonadFileSystem m', m ~ t m') =>+ FilePath -> m ()+ setCurrentDirectory = lift . setCurrentDirectory+ writeFile :: FilePath -> String -> m ()+ default writeFile :: (MonadTrans t, MonadFileSystem m', m ~ t m') =>+ String -> FilePath -> m ()+ writeFile path contents = lift $ writeFile path contents++instance (MonadFileSystem m) => MonadFileSystem (ContT r m)++instance (MonadFileSystem m) => MonadFileSystem (ExceptT e m)++instance (MonadFileSystem m) => MonadFileSystem (IdentityT m)++instance (MonadFileSystem m) => MonadFileSystem (MaybeT m)++instance (MonadFileSystem m) => MonadFileSystem (ReaderT r m)++instance (Monoid w, MonadFileSystem m) =>+ MonadFileSystem (LazyRWS.RWST r w s m)++instance (Monoid w, MonadFileSystem m) =>+ MonadFileSystem (StrictRWS.RWST r w s m)++instance (MonadFileSystem m) => MonadFileSystem (LazyState.StateT s m)++instance (MonadFileSystem m) => MonadFileSystem (StrictState.StateT s m)++instance (Monoid w, MonadFileSystem m) =>+ MonadFileSystem (LazyWriter.WriterT w m)++instance (Monoid w, MonadFileSystem m) =>+ MonadFileSystem (StrictWriter.WriterT w m)++instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadFileSystem m where+ copyFile :: FilePath -> FilePath -> m ()+ copyFile src dest = liftIO $ System.Directory.copyFile src dest+ createDirectoryIfMissing :: Bool -> FilePath -> m ()+ createDirectoryIfMissing createParentDirs path =+ liftIO $ System.Directory.createDirectoryIfMissing createParentDirs path+ doesDirectoryExist :: FilePath -> m Bool+ doesDirectoryExist = liftIO . System.Directory.doesDirectoryExist+ getCurrentDirectory :: m FilePath+ getCurrentDirectory = liftIO System.Directory.getCurrentDirectory+ getDirectoryContents :: FilePath -> m [FilePath]+ getDirectoryContents = liftIO . System.Directory.getDirectoryContents+ getTemporaryDirectory :: m FilePath+ getTemporaryDirectory = liftIO System.Directory.getTemporaryDirectory+ readFile :: FilePath -> m String+ readFile = liftIO . S.readFile+ removeFile :: FilePath -> m ()+ removeFile = liftIO . System.Directory.removeFile+ setCurrentDirectory :: FilePath -> m ()+ setCurrentDirectory = liftIO . System.Directory.setCurrentDirectory+ writeFile :: FilePath -> String -> m ()+ writeFile filePath contents = liftIO $ Prelude.writeFile filePath contents++-- Adapted from http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html.+getDirectoryContentsRec ::+ (Monad m, MonadFileSystem m) => FilePath -> m [FilePath]+getDirectoryContentsRec dir = do+ names <- getDirectoryContents dir+ let properNames = filter (`notElem` [".", ".."]) names+ paths <-+ forM properNames $ \name -> do+ let path = dir </> name+ isDirectory <- doesDirectoryExist path+ if isDirectory+ then getDirectoryContentsRec path+ else pure [path]+ pure $ concat paths++withCurrentDirectory :: (MonadFileSystem m) => FilePath -> m a -> m a+withCurrentDirectory directory f = do+ originalDirectory <- getCurrentDirectory+ setCurrentDirectory directory+ result <- f+ setCurrentDirectory originalDirectory+ pure result++withTemporaryDirectory :: (MonadFileSystem m) => (FilePath -> m a) -> m a+withTemporaryDirectory action = getTemporaryDirectory >>= action
+ src/Axel/Monad/Process.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Monad.Process where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Identity (IdentityT)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.Cont (ContT)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST)+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT)+import qualified Control.Monad.Trans.State.Strict as StrictState (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT)+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT)++import qualified System.Environment (getArgs)+import System.Exit (ExitCode)+import qualified System.Process (readProcessWithExitCode)+import qualified System.Process.Typed (proc, runProcess)++class (Monad m) =>+ MonadProcess m+ where+ getArgs :: m [String]+ default getArgs :: (MonadTrans t, MonadProcess m', m ~ t m') =>+ m [String]+ getArgs = lift getArgs+ runProcess :: FilePath -> [String] -> String -> m (ExitCode, String, String)+ default runProcess :: (MonadTrans t, MonadProcess m', m ~ t m') =>+ FilePath -> [String] -> String -> m (ExitCode, String, String)+ runProcess cmd args stdin = lift $ runProcess cmd args stdin+ runProcessInheritingStreams :: FilePath -> [String] -> m ExitCode+ default runProcessInheritingStreams :: ( MonadTrans t+ , MonadProcess m'+ , m ~ t m'+ ) =>+ FilePath -> [String] -> m ExitCode+ runProcessInheritingStreams cmd args =+ lift $ runProcessInheritingStreams cmd args++instance (MonadProcess m) => MonadProcess (ContT r m)++instance (MonadProcess m) => MonadProcess (ExceptT e m)++instance (MonadProcess m) => MonadProcess (IdentityT m)++instance (MonadProcess m) => MonadProcess (MaybeT m)++instance (MonadProcess m) => MonadProcess (ReaderT r m)++instance (Monoid w, MonadProcess m) => MonadProcess (LazyRWS.RWST r w s m)++instance (Monoid w, MonadProcess m) =>+ MonadProcess (StrictRWS.RWST r w s m)++instance (MonadProcess m) => MonadProcess (LazyState.StateT s m)++instance (MonadProcess m) => MonadProcess (StrictState.StateT s m)++instance (Monoid w, MonadProcess m) =>+ MonadProcess (LazyWriter.WriterT w m)++instance (Monoid w, MonadProcess m) =>+ MonadProcess (StrictWriter.WriterT w m)++instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadProcess m where+ getArgs :: m [String]+ getArgs = liftIO System.Environment.getArgs+ runProcess :: FilePath -> [String] -> String -> m (ExitCode, String, String)+ runProcess cmd args stdin =+ liftIO $ System.Process.readProcessWithExitCode cmd args stdin+ runProcessInheritingStreams cmd args =+ liftIO $+ System.Process.Typed.runProcess (System.Process.Typed.proc cmd args)
+ src/Axel/Monad/Resource.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Monad.Resource where++import Axel.Monad.FileSystem as FS (MonadFileSystem(readFile))++import Control.Monad ((>=>))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Identity (IdentityT)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.Cont (ContT)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST)+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT)+import qualified Control.Monad.Trans.State.Strict as StrictState (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT)+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT)++import Paths_axel (getDataFileName)++import System.FilePath ((</>))++newtype ResourceId =+ ResourceId String++class (Monad m) =>+ MonadResource m+ where+ getResourcePath :: ResourceId -> m FilePath+ default getResourcePath :: (MonadTrans t, MonadResource m', m ~ t m') =>+ ResourceId -> m FilePath+ getResourcePath = lift . getResourcePath++instance (MonadResource m) => MonadResource (ContT r m)++instance (MonadResource m) => MonadResource (ExceptT e m)++instance (MonadResource m) => MonadResource (IdentityT m)++instance (MonadResource m) => MonadResource (MaybeT m)++instance (MonadResource m) => MonadResource (ReaderT r m)++instance (Monoid w, MonadResource m) =>+ MonadResource (LazyRWS.RWST r w s m)++instance (Monoid w, MonadResource m) =>+ MonadResource (StrictRWS.RWST r w s m)++instance (MonadResource m) => MonadResource (LazyState.StateT s m)++instance (MonadResource m) => MonadResource (StrictState.StateT s m)++instance (Monoid w, MonadResource m) =>+ MonadResource (LazyWriter.WriterT w m)++instance (Monoid w, MonadResource m) =>+ MonadResource (StrictWriter.WriterT w m)++instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadResource m where+ getResourcePath :: ResourceId -> m FilePath+ getResourcePath (ResourceId resource) =+ liftIO $ getDataFileName ("resources" </> resource)++readResource :: (MonadFileSystem m, MonadResource m) => ResourceId -> m String+readResource = getResourcePath >=> FS.readFile++astDefinition :: ResourceId+astDefinition = ResourceId "autogenerated/macros/AST.hs"++macroDefinitionAndEnvironmentFooter :: ResourceId+macroDefinitionAndEnvironmentFooter =+ ResourceId "macros/MacroDefinitionAndEnvironmentFooter.hs"++macroDefinitionAndEnvironmentHeader :: ResourceId+macroDefinitionAndEnvironmentHeader =+ ResourceId "macros/MacroDefinitionAndEnvironmentHeader.hs"++macroScaffold :: ResourceId+macroScaffold = ResourceId "macros/Scaffold.hs"++newProjectTemplate :: ResourceId+newProjectTemplate = ResourceId "new-project-template"
src/Axel/Normalize.hs view
@@ -5,28 +5,29 @@ module Axel.Normalize where import Axel.AST- ( ArgumentList(ArgumentList)- , CaseBlock(CaseBlock)+ ( CaseBlock(CaseBlock) , DataDeclaration(DataDeclaration) , Expression(ECaseBlock, EEmptySExpression, EFunctionApplication, EIdentifier, ELambda, ELetBlock, ELiteral) , FunctionApplication(FunctionApplication) , FunctionDefinition(FunctionDefinition)+ , Identifier , Import(ImportItem, ImportType) , ImportSpecification(ImportAll, ImportOnly) , Lambda(Lambda)- , LanguagePragma(LanguagePragma) , LetBlock(LetBlock) , Literal(LChar, LInt, LString) , MacroDefinition(MacroDefinition)+ , Pragma(Pragma) , QualifiedImport(QualifiedImport) , RestrictedImport(RestrictedImport)- , Statement(SDataDeclaration, SFunctionDefinition, SLanguagePragma,- SMacroDefinition, SModuleDeclaration, SQualifiedImport,- SRestrictedImport, STopLevel, STypeSynonym, STypeclassInstance,+ , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,+ SModuleDeclaration, SPragma, SQualifiedImport, SRestrictedImport,+ STopLevel, STypeSignature, STypeSynonym, STypeclassInstance, SUnrestrictedImport) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor)+ , TypeSignature(TypeSignature) , TypeSynonym(TypeSynonym) , TypeclassInstance(TypeclassInstance) )@@ -35,7 +36,6 @@ ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression, Symbol) )-import Axel.Quote (quoteParseExpression) import Control.Monad.Except (MonadError, throwError) @@ -54,12 +54,12 @@ (,) <$> normalizeExpression pat <*> normalizeExpression body x -> throwError $ NormalizeError "Invalid case!" [x, expr]) cases- in ECaseBlock <$>- (CaseBlock <$> normalizeExpression var <*> normalizedCases)- [Parse.Symbol "fn", Parse.SExpression args, body] ->+ in ECaseBlock <$>+ (CaseBlock <$> normalizeExpression var <*> normalizedCases)+ [Parse.Symbol "\\", Parse.SExpression args, body] -> let normalizedArguments = traverse normalizeExpression args- in ELambda <$>- (Lambda <$> normalizedArguments <*> normalizeExpression body)+ in ELambda <$>+ (Lambda <$> normalizedArguments <*> normalizeExpression body) [Parse.Symbol "let", Parse.SExpression bindings, body] -> let normalizedBindings = traverse@@ -69,9 +69,8 @@ normalizeExpression value x -> throwError $ NormalizeError "Invalid pattern!" [x, expr]) bindings- in ELetBlock <$>- (LetBlock <$> normalizedBindings <*> normalizeExpression body)- [Parse.Symbol "quote", expr'] -> pure $ quoteParseExpression expr'+ in ELetBlock <$>+ (LetBlock <$> normalizedBindings <*> normalizeExpression body) fn:args -> EFunctionApplication <$> (FunctionApplication <$> normalizeExpression fn <*>@@ -79,34 +78,27 @@ [] -> pure EEmptySExpression normalizeExpression (Parse.Symbol symbol) = pure $ EIdentifier symbol -normalizeDefinitions ::+normalizeFunctionDefinition :: (MonadError Error m)- => Parse.Expression+ => Identifier -> [Parse.Expression]- -> m [(ArgumentList, Expression)]-normalizeDefinitions ctxt =- traverse- (\case- Parse.SExpression [Parse.SExpression args, body] ->- (,) <$> (ArgumentList <$> traverse normalizeExpression args) <*>- normalizeExpression body- x -> throwError $ NormalizeError "Invalid definition!" [x, ctxt])+ -> Parse.Expression+ -> m FunctionDefinition+normalizeFunctionDefinition fnName arguments body =+ FunctionDefinition fnName <$> traverse normalizeExpression arguments <*>+ normalizeExpression body normalizeStatement :: (MonadError Error m) => Parse.Expression -> m Statement normalizeStatement expr@(Parse.SExpression items) = case items of- Parse.Symbol "=":Parse.Symbol fnName:typeSig:defs ->- normalizeExpression typeSig >>= \case- EFunctionApplication normalizedTypeSig ->- SFunctionDefinition <$>- (FunctionDefinition fnName normalizedTypeSig <$>- normalizeDefinitions expr defs)- _ ->- throwError $ NormalizeError "Invalid type signature!" [typeSig, expr]+ [Parse.Symbol "::", Parse.Symbol fnName, typeDef] ->+ STypeSignature <$> (TypeSignature fnName <$> normalizeExpression typeDef)+ [Parse.Symbol "=", Parse.Symbol fnName, Parse.SExpression arguments, body] ->+ SFunctionDefinition <$> normalizeFunctionDefinition fnName arguments body Parse.Symbol "begin":stmts -> let normalizedStmts = traverse normalizeStatement stmts- in STopLevel . TopLevel <$> normalizedStmts- [Parse.Symbol "data", typeDef, Parse.SExpression constructors] ->+ in STopLevel . TopLevel <$> normalizedStmts+ Parse.Symbol "data":typeDef:constructors -> let normalizedConstructors = traverse (\x ->@@ -117,27 +109,28 @@ throwError $ NormalizeError "Invalid type constructor!" [x, expr]) constructors- in normalizeExpression typeDef >>= \case- EFunctionApplication typeConstructor ->- SDataDeclaration <$>- (DataDeclaration (TypeConstructor typeConstructor) <$>- normalizedConstructors)- EIdentifier properType ->- SDataDeclaration <$>- (DataDeclaration (ProperType properType) <$> normalizedConstructors)- _ -> throwError $ NormalizeError "Invalid type!" [typeDef, expr]- Parse.Symbol "defmacro":Parse.Symbol macroName:defs ->- SMacroDefinition <$>- (MacroDefinition macroName <$> normalizeDefinitions expr defs)- [Parse.Symbol "import", Parse.Symbol moduleName, Parse.SExpression imports] ->+ in normalizeExpression typeDef >>= \case+ EFunctionApplication typeConstructor ->+ SDataDeclaration <$>+ (DataDeclaration (TypeConstructor typeConstructor) <$>+ normalizedConstructors)+ EIdentifier properType ->+ SDataDeclaration <$>+ (DataDeclaration (ProperType properType) <$>+ normalizedConstructors)+ _ -> throwError $ NormalizeError "Invalid type!" [typeDef, expr]+ [Parse.Symbol "macro", Parse.Symbol macroName, Parse.SExpression arguments, body] ->+ SMacroDefinition . MacroDefinition <$>+ normalizeFunctionDefinition macroName arguments body+ [Parse.Symbol "import", Parse.Symbol moduleName, importSpec] -> SRestrictedImport <$>- (RestrictedImport moduleName <$> normalizeImportList expr imports)+ (RestrictedImport moduleName <$> normalizeImportSpec expr importSpec) [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, Parse.SExpression defs] ->+ Parse.Symbol "instance":instanceName:defs -> let normalizedDefs = traverse (\x ->@@ -146,17 +139,17 @@ _ -> throwError $ NormalizeError "Invalid definition!" [x, expr]) defs- in STypeclassInstance <$>- (TypeclassInstance <$> normalizeExpression instanceName <*>- normalizedDefs)- [Parse.Symbol "language", Parse.Symbol languageName] ->- pure $ SLanguagePragma (LanguagePragma languageName)+ in STypeclassInstance <$>+ (TypeclassInstance <$> normalizeExpression instanceName <*>+ normalizedDefs)+ [Parse.Symbol "pragma", Parse.LiteralString pragma] ->+ pure $ SPragma (Pragma pragma) [Parse.Symbol "module", Parse.Symbol moduleName] -> pure $ SModuleDeclaration moduleName [Parse.Symbol "type", alias, def] -> let normalizedAlias = normalizeExpression alias normalizedDef = normalizeExpression def- in STypeSynonym <$> (TypeSynonym <$> normalizedAlias <*> normalizedDef)+ in STypeSynonym <$> (TypeSynonym <$> normalizedAlias <*> normalizedDef) _ -> throwError $ NormalizeError "Invalid top-level form!" [expr] where normalizeImportSpec ctxt importSpec =@@ -180,7 +173,7 @@ throwError $ NormalizeError "Invalid import!" [x, item, ctxt]) imports- in ImportType type' <$> normalizedImports+ in ImportType type' <$> normalizedImports x -> throwError $ NormalizeError "Invalid import!" [x, item, ctxt]) input normalizeStatement expr =
src/Axel/Parse.hs view
@@ -5,6 +5,7 @@ -- 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 #-} @@ -13,7 +14,7 @@ , module Axel.Parse.AST ) where -import Axel.Error (Error(ParseError))+import Axel.Error (Error(ParseError), fatal) -- Re-exporting these so that consumers of parsed ASTs do not need -- to know about the internal file.@@ -22,7 +23,9 @@ Symbol) ) import Axel.Utils.List (takeUntil)-import Axel.Utils.Recursion (Recursive(bottomUpFmap, bottomUpTraverse))+import Axel.Utils.Recursion+ ( Recursive(bottomUpFmap, bottomUpTraverse, topDownFmap)+ ) import Control.Monad.Except (MonadError, throwError) @@ -63,6 +66,14 @@ 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 parseReadMacro :: (Stream s m Char) => String -> String -> ParsecT s u m Expression@@ -77,14 +88,14 @@ whitespace = many space literalChar :: (Stream s m Char) => ParsecT s u m Expression-literalChar = LiteralChar <$> (char '\\' *> any')+literalChar = LiteralChar <$> (char '{' *> any' <* char '}') literalInt :: (Stream s m Char) => ParsecT s u m Expression literalInt = LiteralInt . read <$> many1 digit literalList :: (Stream s m Char) => ParsecT s u m Expression literalList =- (SExpression . (Symbol "list" :)) <$> (char '[' *> many item <* char ']')+ SExpression . (Symbol "list" :) <$> (char '[' *> many item <* char ']') where item = try (whitespace *> expression) <|> expression @@ -125,24 +136,59 @@ sExpression <|> symbol -stripComments :: String -> String-stripComments = unlines . map cleanLine . lines+-- 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) =+ SExpression+ [ Symbol "AST.SExpression"+ , SExpression (Symbol "list" : map quoteParseExpression xs)+ ]+quoteParseExpression (Symbol x) =+ SExpression [Symbol "AST.Symbol", LiteralString (handleEscapes x)] where- cleanLine = takeUntil "--"+ handleEscapes =+ concatMap $ \case+ '\\' -> "\\\\"+ c -> [c] parseMultiple :: (MonadError Error m) => String -> m [Expression] parseMultiple =- either (throwError . ParseError) pure .+ either (throwError . ParseError . show) (pure . map expandQuotes) . parse (many1 (optional whitespace *> expression <* optional whitespace) <* eof) ""+ where+ expandQuotes =+ topDownFmap+ (\case+ SExpression [Symbol "quote", x] -> quoteParseExpression x+ x -> x) parseSingle :: (MonadError Error m) => String -> m Expression-parseSingle =- either (throwError . ParseError) pure .- parse (optional whitespace *> expression <* optional whitespace <* eof) ""+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 :: (MonadError Error m) => String -> m 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"++topLevelExpressionsToProgram :: [Expression] -> Expression+topLevelExpressionsToProgram stmts = SExpression (Symbol "begin" : stmts)
src/Axel/Parse/AST.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+ -- 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@@ -21,7 +24,7 @@ -- Internal utilities -- ****************************** toAxel :: Expression -> String-toAxel (LiteralChar x) = ['\\', x]+toAxel (LiteralChar x) = ['{', x, '}'] toAxel (LiteralInt x) = show x toAxel (LiteralString xs) = "\"" ++ xs ++ "\"" toAxel (SExpression xs) = "(" ++ unwords (map toAxel xs) ++ ")"@@ -40,3 +43,20 @@ let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" ++ show suffix modifyIORef gensymCounter succ pure $ Symbol identifier++-- | This allows splice-unquoting of both `[Expression]`s and `SExpression`s, without requiring special syntax for each.+class ToExpressionList a where+ toExpressionList :: a -> [Expression]++instance ToExpressionList [Expression] where+ toExpressionList :: [Expression] -> [Expression]+ 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+ toExpressionList x =+ error+ (show x <>+ " cannot be splice-unquoted, because it is not an s-expression!")
+ src/Axel/Parse/Args.hs view
@@ -0,0 +1,31 @@+module Axel.Parse.Args where++import Data.Semigroup ((<>))++import Options.Applicative+ ( Parser+ , argument+ , command+ , info+ , metavar+ , progDesc+ , str+ , subparser+ )++data ModeCommand+ = File FilePath+ | Project++modeCommandParser :: Parser ModeCommand+modeCommandParser = subparser $ projectCommand <> fileCommand+ where+ fileCommand =+ command+ "file"+ (info (File <$> argument str (metavar "FILE")) $+ progDesc "Build and run a single file")+ projectCommand =+ command+ "project"+ (info (pure Project) $ progDesc "Build and run the project")
− src/Axel/Project.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Axel.Project where--import Axel.Entry (transpileFile')-import Axel.Utils.Directory (getRecursiveContents)--import Control.Lens ((%~))-import Control.Monad (void)-import Control.Monad.Except (throwError)-import Control.Monad.IO.Class (liftIO)--import Data.Aeson.Lens (_Array, key)-import Data.Function ((&))-import Data.List (foldl')-import Data.Semigroup ((<>))-import qualified Data.Text as T (append, isSuffixOf, pack)-import Data.Vector (cons)-import Data.Version (showVersion)-import Data.Yaml (Value(String), decodeFileEither, encodeFile)--import Paths_axel (getDataFileName, version)--import System.Directory (copyFile, removeFile, setCurrentDirectory)-import System.FilePath ((</>))-import System.Process (readProcess, readProcessWithExitCode)-import System.Process.Typed (proc, runProcess)--import Text.Regex.PCRE ((=~), getAllTextSubmatches)--newProject :: String -> IO ()-newProject projectName = do- void $ readProcess "stack" ["new", projectName, "new-template"] ""- setCurrentDirectory projectName- void $- readProcess "stack" ["config", "set", "resolver", "nightly-2018-08-17"] ""- templatePath <- getDataFileName ("resources" </> "new-project-template")- let copyAxel filePath = do- copyFile- (templatePath </> filePath <> ".axel")- (projectName </> filePath <> ".axel")- removeFile (projectName </> filePath <> ".hs")- mapM_ copyAxel ["Setup", "app" </> "Main", "src" </> "Lib", "test" </> "Spec"]--transpileProject :: IO [FilePath]-transpileProject = do- files <- getRecursiveContents "."- let axelFiles =- filter (\filePath -> ".axel" `T.isSuffixOf` T.pack filePath) files- mapM transpileFile' axelFiles--addAxelDependency :: IO ()-addAxelDependency = do- let packageConfigPath = "package.yaml"- let axelHackageVersion = T.pack $ showVersion version- decodeResult <- decodeFileEither packageConfigPath- case decodeResult of- Right contents ->- let newContents :: Value- newContents =- contents & key "dependencies" . _Array %~- cons (String $ T.append "axel ==" axelHackageVersion)- in encodeFile packageConfigPath newContents- Left err ->- throwError- (userError $ "`package.yaml` could not be parsed: " <> show err)--buildProject :: IO ()-buildProject = do- hsPaths <- transpileProject- addAxelDependency- void $ readProcess "stack" ["build"] ""- mapM_ removeFile hsPaths--runProject :: IO ()-runProject = do- (_, _, stderr) <- readProcessWithExitCode "stack" ["ide", "targets"] ""- let targets = lines stderr- case findExeTargets targets of- [target] -> do- liftIO $ putStrLn ("Running " <> target <> "...")- void $ runProcess $ proc "stack" ["exec", target]- _ -> throwError (userError "No executable target was unambiguously found!")- where- findExeTargets =- foldl'- (\acc target ->- case getAllTextSubmatches $ target =~- ("([^:]*):exe:([^:]*)" :: String) of- [_fullMatch, _projectName, targetName] -> targetName : acc- _ -> acc)- []
− src/Axel/Quote.hs
@@ -1,47 +0,0 @@-module Axel.Quote where--import qualified Axel.AST as AST- ( Expression(EFunctionApplication, EIdentifier, ELiteral)- , FunctionApplication(FunctionApplication)- , Literal(LChar, LInt, LString)- )-import qualified Axel.Parse as Parse- ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,- Symbol)- )--quoteList :: [Parse.Expression] -> AST.Expression-quoteList =- foldr- (\x acc ->- AST.EFunctionApplication- (AST.FunctionApplication- (AST.EIdentifier ":")- [quoteParseExpression x, acc]))- (AST.EIdentifier "[]")---- TODO Derive this with Template Haskell (it's really brittle, currently).-quoteParseExpression :: Parse.Expression -> AST.Expression-quoteParseExpression (Parse.LiteralChar x) =- AST.EFunctionApplication $- AST.FunctionApplication- (AST.EIdentifier "AST.LiteralChar")- [AST.ELiteral $ AST.LChar x]-quoteParseExpression (Parse.LiteralInt x) =- AST.EFunctionApplication $- AST.FunctionApplication- (AST.EIdentifier "AST.LiteralInt")- [AST.ELiteral $ AST.LInt x]-quoteParseExpression (Parse.LiteralString x) =- AST.EFunctionApplication $- AST.FunctionApplication- (AST.EIdentifier "AST.LiteralString")- [AST.ELiteral $ AST.LString x]-quoteParseExpression (Parse.SExpression xs) =- AST.EFunctionApplication $- AST.FunctionApplication (AST.EIdentifier "AST.SExpression") [quoteList xs]-quoteParseExpression (Parse.Symbol x) =- AST.EFunctionApplication $- AST.FunctionApplication- (AST.EIdentifier "AST.Symbol")- [AST.ELiteral $ AST.LString x]
src/Axel/Utils/Debug.hs view
@@ -2,8 +2,8 @@ import Debug.Trace (trace, traceShow) -unsafeTee :: String -> a -> a-unsafeTee = trace+unsafeTee :: String -> String+unsafeTee x = trace x x unsafeTeeS :: Show a => a -> a unsafeTeeS x = traceShow x x
− src/Axel/Utils/Directory.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Axel.Utils.Directory where--import Control.Monad (forM)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Control (MonadBaseControl, control)--import System.Directory- ( createDirectoryIfMissing- , doesDirectoryExist- , getDirectoryContents- , getTemporaryDirectory- , withCurrentDirectory- )-import System.FilePath ((</>))---- Adapted from http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html.-getRecursiveContents :: FilePath -> IO [FilePath]-getRecursiveContents startDir = do- names <- getDirectoryContents startDir- let properNames = filter (`notElem` [".", ".."]) names- paths <-- forM properNames $ \name -> do- let path = startDir </> name- isDirectory <- doesDirectoryExist path- if isDirectory- then getRecursiveContents path- else pure [path]- pure $ concat paths--withCurrentDirectoryLifted :: (MonadBaseControl IO m) => FilePath -> m a -> m a-withCurrentDirectoryLifted directory f =- control $ \runInIO -> withCurrentDirectory directory (runInIO f)--withTempDirectory :: (MonadIO m) => (FilePath -> m a) -> m a-withTempDirectory f = do- temporaryDirectory <- liftIO getTemporaryDirectory- liftIO $ createDirectoryIfMissing True temporaryDirectory- result <- f temporaryDirectory- pure result
src/Axel/Utils/Display.hs view
@@ -8,6 +8,7 @@ = Commas | Newlines | Pipes+ | Semicolons | Spaces delimit :: Delimiter -> [String] -> String@@ -16,6 +17,7 @@ lookupDelimiter Commas = "," lookupDelimiter Newlines = "\n" lookupDelimiter Pipes = "|"+ lookupDelimiter Semicolons = ";" lookupDelimiter Spaces = " " -- https://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators@@ -27,7 +29,7 @@ lowerFirst "" = "" renderBlock :: [String] -> String-renderBlock = surround CurlyBraces . intercalate ";"+renderBlock = surround CurlyBraces . delimit Semicolons renderPragma :: String -> String renderPragma x = "{-# " <> x <> " #-}"
src/Axel/Utils/Recursion.hs view
@@ -13,3 +13,4 @@ -- TODO Remove dependency on `Monad` in favor of `Applicative` -- (which is all the standard `traverse` requires). bottomUpTraverse :: (Monad m) => (a -> m a) -> a -> m a+ topDownFmap :: (a -> a) -> a -> a
− src/Axel/Utils/Resources.hs
@@ -1,28 +0,0 @@-module Axel.Utils.Resources where--import Control.Monad ((>=>))--import Paths_axel (getDataFileName)--import System.FilePath ((</>))--import qualified System.IO.Strict as S (readFile)--newtype Resource =- Resource String--getResourcePath :: Resource -> IO FilePath-getResourcePath (Resource resource) = getDataFileName $ "resources" </> resource--readResource :: Resource -> IO String-readResource = getResourcePath >=> S.readFile--astDefinition :: Resource-astDefinition = Resource "autogenerated/macros/AST.hs"--macroDefinitionAndEnvironmentHeader :: Resource-macroDefinitionAndEnvironmentHeader =- Resource "macros/MacroDefinitionAndEnvironmentHeader.hs"--macroScaffold :: Resource-macroScaffold = Resource "macros/Scaffold.hs"
+ test/Axel/Test/ASTGen.hs view
@@ -0,0 +1,130 @@+module Axel.Test.ASTGen where++import qualified Axel.AST as AST++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++genIdentifier :: (MonadGen m) => m AST.Identifier+genIdentifier = Gen.string (Range.linear 1 5) Gen.alpha++genLiteral :: (MonadGen m) => m AST.Literal+genLiteral =+ Gen.choice+ [ AST.LChar <$> Gen.unicode+ , AST.LInt <$> Gen.int Range.constantBounded+ , AST.LString <$> Gen.string (Range.linear 0 5) Gen.unicode+ ]++genCaseBlock :: (MonadGen m) => m AST.CaseBlock+genCaseBlock =+ AST.CaseBlock <$> genExpression <*>+ Gen.list (Range.linear 0 3) ((,) <$> genExpression <*> genExpression)++genFunctionApplication :: (MonadGen m) => m AST.FunctionApplication+genFunctionApplication =+ AST.FunctionApplication <$> genExpression <*>+ Gen.list (Range.linear 0 3) genExpression++genLambda :: (MonadGen m) => m AST.Lambda+genLambda =+ AST.Lambda <$> Gen.list (Range.linear 0 3) genExpression <*> genExpression++genLetBlock :: (MonadGen m) => m AST.LetBlock+genLetBlock =+ AST.LetBlock <$>+ Gen.list (Range.linear 0 3) ((,) <$> genExpression <*> genExpression) <*>+ genExpression++genExpression :: (MonadGen m) => m AST.Expression+genExpression =+ Gen.recursive+ Gen.choice+ [pure AST.EEmptySExpression, AST.EIdentifier <$> genIdentifier]+ [ AST.ECaseBlock <$> genCaseBlock+ , AST.EFunctionApplication <$> genFunctionApplication+ , AST.ELambda <$> genLambda+ , AST.ELetBlock <$> genLetBlock+ , AST.ELiteral <$> genLiteral+ ]++genTypeDefinition :: (MonadGen m) => m AST.TypeDefinition+genTypeDefinition =+ Gen.choice+ [ AST.ProperType <$> genIdentifier+ , AST.TypeConstructor <$> genFunctionApplication+ ]++genDataDeclaration :: (MonadGen m) => m AST.DataDeclaration+genDataDeclaration =+ AST.DataDeclaration <$> genTypeDefinition <*>+ Gen.list (Range.linear 0 3) genFunctionApplication++genFunctionDefinition :: (MonadGen m) => m AST.FunctionDefinition+genFunctionDefinition =+ AST.FunctionDefinition <$> genIdentifier <*>+ Gen.list (Range.linear 0 3) genExpression <*>+ genExpression++genPragma :: (MonadGen m) => m AST.Pragma+genPragma = AST.Pragma <$> Gen.string (Range.linear 0 10) Gen.ascii++genMacroDefinition :: (MonadGen m) => m AST.MacroDefinition+genMacroDefinition = AST.MacroDefinition <$> genFunctionDefinition++genImport :: (MonadGen m) => m AST.Import+genImport =+ Gen.choice+ [ AST.ImportItem <$> genIdentifier+ , AST.ImportType <$> genIdentifier <*>+ 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+ ]++genQualifiedImport :: (MonadGen m) => m AST.QualifiedImport+genQualifiedImport =+ AST.QualifiedImport <$> genIdentifier <*> genIdentifier <*>+ genImportSpecification++genRestrictedImport :: (MonadGen m) => m AST.RestrictedImport+genRestrictedImport =+ AST.RestrictedImport <$> genIdentifier <*> genImportSpecification++genTopLevel :: (MonadGen m) => m AST.TopLevel+genTopLevel = AST.TopLevel <$> Gen.list (Range.linear 0 3) genStatement++genTypeclassInstance :: (MonadGen m) => m AST.TypeclassInstance+genTypeclassInstance =+ AST.TypeclassInstance <$> genExpression <*>+ Gen.list (Range.linear 0 3) genFunctionDefinition++genTypeSignature :: (MonadGen m) => m AST.TypeSignature+genTypeSignature = AST.TypeSignature <$> genIdentifier <*> genExpression++genTypeSynonym :: (MonadGen m) => m AST.TypeSynonym+genTypeSynonym = AST.TypeSynonym <$> genExpression <*> genExpression++genStatement :: (MonadGen m) => m AST.Statement+genStatement =+ Gen.recursive+ Gen.choice+ [ AST.SDataDeclaration <$> genDataDeclaration+ , AST.SFunctionDefinition <$> genFunctionDefinition+ , AST.SPragma <$> genPragma+ , AST.SMacroDefinition <$> genMacroDefinition+ , AST.SModuleDeclaration <$> genIdentifier+ , AST.SQualifiedImport <$> genQualifiedImport+ , AST.SRestrictedImport <$> genRestrictedImport+ , AST.STypeclassInstance <$> genTypeclassInstance+ , AST.STypeSignature <$> genTypeSignature+ , AST.STypeSynonym <$> genTypeSynonym+ , AST.SUnrestrictedImport <$> genIdentifier+ ]+ [AST.STopLevel <$> genTopLevel]
+ test/Axel/Test/DenormalizeSpec.hs view
@@ -0,0 +1,20 @@+module Axel.Test.DenormalizeSpec where++import Axel.Denormalize+import Axel.Normalize+import qualified Axel.Test.ASTGen as ASTGen+import Axel.Test.MockUtils++import Hedgehog++hprop_normalizeExpression_is_the_inverse_of_denormalizeExpression :: Property+hprop_normalizeExpression_is_the_inverse_of_denormalizeExpression =+ property $ do+ expr <- forAll ASTGen.genExpression+ expr === unwrapRight (normalizeExpression (denormalizeExpression expr))++hprop_normalizeStatement_is_the_inverse_of_denormalizeStatement :: Property+hprop_normalizeStatement_is_the_inverse_of_denormalizeStatement =+ property $ do+ stmt <- forAll ASTGen.genStatement+ stmt === unwrapRight (normalizeStatement (denormalizeStatement stmt))
+ test/Axel/Test/File/FileSpec.hs view
@@ -0,0 +1,25 @@+module Axel.Test.File.FileSpec where++import Axel.Error as Error+import Axel.Haskell.File+import Axel.Monad.FileSystem as FS++import Data.ByteString.Lazy.Char8 as C++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 <$> Error.toIO (FS.readFile axelFile >>= transpileSource))
+ test/Axel/Test/Haskell/GHCSpec.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts #-}++module Axel.Test.Haskell.GHCSpec where++import Axel.Haskell.GHC as GHC+import Axel.Haskell.Stack as Stack+import qualified Axel.Test.Monad.FileSystemMock as Mock+import qualified Axel.Test.Monad.ProcessMock as Mock++import Control.Lens+import Control.Monad.Except++import System.Exit++import Test.Tasty.Hspec++{-# ANN module "HLint: ignore Redundant do" #-}++spec_GHC :: SpecWith ()+spec_GHC = do+ describe "ghcCompile" $ do+ it "compiles a file with GHC" $ do+ let action = GHC.ghcCompile "projectFoo/app/Main.hs"+ let origFSState = Mock.mkFSState []+ let origProcState =+ Mock.mkProcessState+ []+ [ Mock.ProcessResultT+ ((ExitSuccess, Just ("testStdout", "")), pure ())+ ]+ let expectation stdout (procState, _) = do+ stdout `shouldBe` "testStdout"+ procState ^. Mock.procExecutionLog `shouldBe`+ [ ( "stack"+ , [ "--resolver"+ , Stack.stackageResolverWithAxel+ , "ghc"+ , "--"+ , "-v0"+ , "-ddump-json"+ , "projectFoo/app/Main.hs"+ ]+ , Just "")+ ]+ case Mock.runProcess (origProcState, origFSState) $ runExceptT action of+ Left err -> expectationFailure err+ Right (Left err, _) -> expectationFailure err+ Right (Right x, state) -> expectation x state+ describe "ghcInterpret" $ do+ it "interprets a file with GHC" $ do+ let action = GHC.ghcInterpret "projectFoo/app/Main.hs"+ let origFSState = Mock.mkFSState []+ let origProcState =+ Mock.mkProcessState+ []+ [ Mock.ProcessResultT+ ((ExitSuccess, Just ("testStdout", "")), pure ())+ ]+ let expectation stdout (procState, _) = do+ stdout `shouldBe` "testStdout"+ procState ^. Mock.procExecutionLog `shouldBe`+ [ ( "stack"+ , [ "--resolver"+ , stackageResolverWithAxel+ , "runghc"+ , "--package"+ , axelStackageId+ , "--"+ , "projectFoo/app/Main.hs"+ ]+ , Just "")+ ]+ case Mock.runProcess (origProcState, origFSState) $ runExceptT action of+ Left err -> expectationFailure err+ Right (Left err, _) -> expectationFailure err+ Right (Right x, state) -> expectation x state
+ test/Axel/Test/Haskell/StackSpec.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}++module Axel.Test.Haskell.StackSpec where++import Axel.Haskell.Stack as Stack+import Axel.Monad.FileSystem as FS+import Axel.Test.Monad.ConsoleMock as Mock+import Axel.Test.Monad.FileSystemMock as Mock+import Axel.Test.Monad.ProcessMock as Mock++import Control.Lens+import Control.Monad.Except++import System.Exit++import Test.Tasty.Hspec++{-# ANN module "HLint: ignore Redundant do" #-}++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 origFSState =+ Mock.mkFSState+ [ Mock.Directory+ "project"+ [ Mock.Directory+ "path"+ [Mock.File "package.yaml" "dependencies:\n- asdf-5.6.7"]+ ]+ ]+ let expectedFSState =+ origFSState & Mock.fsRoot . at "project/path/package.yaml" ?~+ Mock.File+ "package.yaml"+ "dependencies:\n- foo-1.2.3.4\n- asdf-5.6.7\n"+ case Mock.runFileSystem origFSState action of+ Left err -> expectationFailure err+ Right ((), result) -> result `shouldBe` expectedFSState+ describe "buildStackProject" $ do+ it "builds a Stack project" $ do+ let action = Stack.buildStackProject "project/path"+ let origFSState =+ Mock.mkFSState [Mock.Directory "project" [Mock.Directory "path" []]]+ let origProcState =+ Mock.mkProcessState+ []+ [ProcessResultT ((ExitSuccess, Just ("", "")), pure ())]+ let expectation result (procState, fsState) = do+ result `shouldBe` ()+ procState ^. Mock.procExecutionLog `shouldBe`+ [("stack", ["build"], Just "")]+ fsState ^. Mock.fsCurrentDirectory `shouldBe` "/"+ case Mock.runProcess (origProcState, origFSState) $ runExceptT action of+ Left err -> expectationFailure err+ Right (Left err, _) -> expectationFailure $ show err+ Right (Right x, state) -> expectation x state+ describe "createStackProject" $ do+ it "creates a new Stack project" $ do+ let action = Stack.createStackProject "newProject"+ let origFSState = Mock.mkFSState []+ let origProcState =+ Mock.mkProcessState+ []+ [ ProcessResultT+ ( (ExitSuccess, Just ("", ""))+ , FS.createDirectoryIfMissing False "newProject")+ , ProcessResultT ((ExitSuccess, Just ("", "")), pure ())+ ]+ let expectation ((), (procState, fsState)) = do+ procState ^. Mock.procExecutionLog `shouldBe`+ [ ("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 Mock.runProcess (origProcState, origFSState) action of+ Left err -> expectationFailure err+ Right result -> expectation result+ describe "runStackProject" $ do+ it "runs a Stack project" $ do+ let action = Stack.runStackProject "project/path"+ let origConsoleState = Mock.mkConsoleState+ let origFSState =+ Mock.mkFSState [Mock.Directory "project" [Mock.Directory "path" []]]+ let origProcState =+ Mock.mkProcessState+ []+ [ ProcessResultT+ ( ( ExitSuccess+ , Just ("", "foo:lib\nfoo:exe:foo-exe\nfoo:test:foo-test"))+ , pure ())+ , ProcessResultT ((ExitSuccess, Nothing), pure ())+ ]+ let expectation result (consoleState, procState, fsState) = do+ result `shouldBe` ()+ procState ^. Mock.procExecutionLog `shouldBe`+ [ ("stack", ["ide", "targets"], Just "")+ , ("stack", ["exec", "foo-exe"], Nothing)+ ]+ fsState ^. Mock.fsCurrentDirectory `shouldBe` "/"+ consoleState ^. Mock.consoleOutput `shouldBe` "Running foo-exe...\n"+ case Mock.runProcess (origProcState, origFSState) $+ Mock.runConsoleT origConsoleState $+ runExceptT action of+ Left err -> expectationFailure err+ Right ((Left err, _), _) -> expectationFailure $ show err+ Right ((Right x, consoleState), (procState, fsState)) ->+ expectation x (consoleState, procState, fsState)
+ test/Axel/Test/MockUtils.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC "-fno-warn-incomplete-patterns" #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}++module Axel.Test.MockUtils where++import Control.Monad.Except+import Control.Monad.State.Lazy++import GHC.Exts (IsString(fromString))++import Language.Haskell.TH.Quote++throwInterpretError ::+ (MonadError String m, MonadState s m, Show s) => String -> String -> m a+throwInterpretError actionName message = do+ errorMsg <-+ gets $ \ctxt ->+ "\n----------\nACTION\t" <> actionName <> "\n\nMESSAGE\t" <> message <>+ "\n\nSTATE\t" <>+ show ctxt <>+ "\n----------\n"+ throwError errorMsg++-- 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")++unwrapRight :: Either b a -> a+unwrapRight (Right x) = x
+ test/Axel/Test/Monad/ConsoleMock.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Axel.Test.Monad.ConsoleMock where++import Axel.Monad.Console as Console+import Axel.Monad.FileSystem as FS+import Axel.Monad.Process as Proc+import Axel.Monad.Resource as Res++import Control.Lens+import Control.Monad.State.Lazy++newtype ConsoleState = ConsoleState+ { _consoleOutput :: String+ } deriving (Eq, Show)++makeFieldsNoPrefix ''ConsoleState++mkConsoleState :: ConsoleState+mkConsoleState = ConsoleState {_consoleOutput = ""}++newtype ConsoleT m a =+ ConsoleT (StateT ConsoleState m a)+ deriving ( Functor+ , Applicative+ , Monad+ , MonadTrans+ , MonadFileSystem+ , MonadProcess+ , MonadResource+ )++type Console = ConsoleT Identity++instance (Monad m) => MonadConsole (ConsoleT m) where+ putStr str = ConsoleT $ consoleOutput <>= str++runConsoleT :: ConsoleState -> ConsoleT m a -> m (a, ConsoleState)+runConsoleT origState (ConsoleT x) = runStateT x origState++runConsole :: ConsoleState -> Console a -> (a, ConsoleState)+runConsole origState x = runIdentity $ runConsoleT origState x
+ test/Axel/Test/Monad/ConsoleSpec.hs view
@@ -0,0 +1,19 @@+module Axel.Test.Monad.ConsoleSpec where++import qualified Axel.Monad.Console as Console+import qualified Axel.Test.Monad.ConsoleMock as Mock++import Test.Tasty.Hspec++{-# ANN module "HLint: ignore Redundant do" #-}++spec_Console :: SpecWith ()+spec_Console =+ describe "putStrLn" $ do+ it "prints to the console with a trailing newline" $ do+ let action = Console.putStrLn "line1\nline2"+ let origState = Mock.mkConsoleState+ let expected = Mock.ConsoleState {Mock._consoleOutput = "line1\nline2\n"}+ case Mock.runConsoleT origState action of+ Left err -> expectationFailure err+ Right result -> result `shouldBe` ((), expected)
+ test/Axel/Test/Monad/FileSystemMock.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Test.Monad.FileSystemMock where++import Axel.Monad.Console as Console+import Axel.Monad.FileSystem as FS+import Axel.Monad.Process as Proc+import Axel.Monad.Resource as Res+import Axel.Test.MockUtils++import Control.Lens hiding (children)+import Control.Monad.Except+import Control.Monad.State.Lazy++import Data.List.Split+import Data.Maybe++import System.FilePath++data FSNode+ = Directory FilePath+ [FSNode]+ | File FilePath+ String+ deriving (Eq, Show)++fsPath :: Lens' FSNode FilePath+fsPath =+ lens+ (\case+ Directory path _ -> path+ File path _ -> path)+ (\node newPath ->+ case node of+ Directory _ children -> Directory newPath children+ File _ contents -> File newPath contents)++data FSState = FSState+ { _fsCurrentDirectory :: FilePath+ , _fsRoot :: FSNode+ , _fsTempCounter :: Int+ } deriving (Eq, Show)++makeFieldsNoPrefix ''FSState++mkFSState :: [FSNode] -> FSState+mkFSState rootContents =+ FSState+ { _fsCurrentDirectory = "/"+ , _fsRoot = Directory "/" rootContents+ , _fsTempCounter = 0+ }++lookupNode :: [FilePath] -> FSNode -> Maybe FSNode+lookupNode _ (File _ _) = Nothing+lookupNode [] _ = Nothing+lookupNode ["."] rootNode = pure rootNode+lookupNode [segment] (Directory _ rootChildren) =+ let matchingChildren =+ filter (\child -> child ^. fsPath == segment) rootChildren+ in case matchingChildren of+ [child] -> pure child+ _ -> Nothing+lookupNode (segment:xs) rootNode@(Directory _ _) = do+ child@(Directory _ _) <- lookupNode [segment] rootNode+ lookupNode xs child++deleteNode :: [FilePath] -> FSNode -> Maybe FSNode+deleteNode _ (File _ _) = Nothing+deleteNode [] _ = Nothing+deleteNode [segment] rootNode@(Directory rootPath rootChildren) = do+ child <- lookupNode [segment] rootNode+ let rootChildren' = filter (/= child) rootChildren+ pure $ Directory rootPath rootChildren'+deleteNode (segment:xs) rootNode@(Directory rootPath rootChildren) = do+ needle <- lookupNode [segment] rootNode+ rootChildren' <-+ mapM+ (\child ->+ case child of+ File _ _ -> pure child+ _ ->+ if child == needle+ then deleteNode xs child+ else pure child)+ rootChildren+ pure $ Directory rootPath rootChildren'++insertNode :: [FilePath] -> FSNode -> FSNode -> Maybe FSNode+insertNode _ _ (File _ _) = Nothing+insertNode [] _ _ = Nothing+insertNode [segment] newNode (Directory rootPath rootChildren) =+ if newNode ^. fsPath == segment+ then let rootChildren' =+ filter+ (\child -> child ^. fsPath /= newNode ^. fsPath)+ rootChildren+ in pure $ Directory rootPath (newNode : rootChildren')+ else Nothing+insertNode (segment:xs) newNode rootNode@(Directory rootPath rootChildren) = do+ needle <- lookupNode [segment] rootNode+ rootChildren' <-+ mapM+ (\child ->+ case child of+ File _ _ -> pure child+ _ ->+ if child == needle+ then insertNode xs newNode child+ else pure child)+ rootChildren+ pure $ Directory rootPath rootChildren'++type instance Index FSNode = FilePath++type instance IxValue FSNode = FSNode++instance Ixed FSNode where+ ix ::+ (Applicative f) => FilePath -> (FSNode -> f FSNode) -> FSNode -> f FSNode+ ix path f root =+ case lookupNode pathSegments root of+ Just node ->+ f node <&> \newNode -> fromJust $ insertNode pathSegments newNode root+ Nothing -> pure root+ where+ pathSegments :: [FilePath]+ pathSegments = splitDirectories path++instance At FSNode where+ at :: FilePath -> Lens' FSNode (Maybe FSNode)+ at path =+ let setter :: FSNode -> Maybe FSNode -> FSNode+ setter root =+ fromMaybe root . \case+ Just newNode -> insertNode pathSegments newNode root+ Nothing -> deleteNode pathSegments root+ in lens (lookupNode pathSegments) setter+ where+ pathSegments :: [FilePath]+ pathSegments = splitDirectories path++absifyPath :: FilePath -> FilePath -> FilePath+absifyPath relativePath currentDirectory =+ let absolutePath =+ case relativePath of+ '/':_ -> relativePath+ _ -> "/" </> currentDirectory </> relativePath+ normalizedSegments =+ concatMap+ (\case+ [_, ".."] -> []+ ["."] -> []+ xs -> xs) $+ chunksOf 2 $+ dropLeadingSlash $+ splitDirectories absolutePath+ in case joinPath normalizedSegments of+ "" -> "/"+ path -> path+ where+ dropLeadingSlash ("/":xs) = xs+ dropLeadingSlash xs = xs++absify :: (MonadState FSState f) => FilePath -> f FilePath+absify relativePath = absifyPath relativePath <$> gets (^. fsCurrentDirectory)++newtype FileSystemT m a =+ FileSystemT (StateT FSState (ExceptT String m) a)+ deriving ( Functor+ , Applicative+ , Monad+ , MonadConsole+ , MonadProcess+ , MonadResource+ )++type FileSystem = FileSystemT Identity++instance Eq (FileSystemT m a) where+ _ == _ = False++instance Show (FileSystemT m a) where+ show _ = "<FileSystemT>"++instance MonadTrans FileSystemT where+ lift = FileSystemT . lift . lift++instance (Monad m) => MonadFileSystem (FileSystemT m) where+ copyFile src dest = do+ contents <- FS.readFile src+ FS.writeFile contents dest+ createDirectoryIfMissing createParents relativePath =+ FileSystemT $ do+ path <- absify relativePath+ parentNode <- gets (^. fsRoot . at (takeDirectory path))+ case parentNode of+ Just _ -> fsRoot . at path ?= Directory (takeFileName path) []+ Nothing ->+ if createParents+ then fsRoot %= \origRoot ->+ fst+ (foldl+ (\(root, segments) pathSegment ->+ let newSegments = segments <> [pathSegment]+ newRoot =+ case root ^. at (joinPath newSegments) of+ Just _ -> root+ Nothing ->+ root & at (joinPath newSegments) ?~+ Directory pathSegment []+ in (newRoot, newSegments))+ (origRoot, [])+ (splitDirectories path))+ else throwInterpretError+ "createDirectoryIfMissing"+ ("Missing parents for directory: " <> path)+ doesDirectoryExist relativePath =+ FileSystemT $ do+ path <- absify relativePath+ directoryNode <- gets (^. fsRoot . at path)+ pure $+ case directoryNode of+ Just (Directory _ _) -> True+ _ -> False+ getCurrentDirectory = FileSystemT $ gets (^. fsCurrentDirectory)+ getDirectoryContents relativePath =+ FileSystemT $ do+ path <- absify relativePath+ directoryNode <- gets (^. fsRoot . at path)+ case directoryNode of+ Just (Directory _ children) -> pure $ map (^. fsPath) children+ _ ->+ throwInterpretError+ "getDirectoryContents"+ ("No such directory: " <> path)+ getTemporaryDirectory = do+ tempCounter <- FileSystemT $ fsTempCounter <<+= 1+ let tempDirName = "/tmp" </> show tempCounter+ FS.createDirectoryIfMissing True tempDirName+ pure tempDirName+ readFile relativePath =+ FileSystemT $ do+ path <- absify relativePath+ fileNode <- gets (^. fsRoot . at path)+ case fileNode of+ Just (File _ contents) -> pure contents+ _ -> throwInterpretError "readFile" ("No such file: " <> path)+ removeFile relativePath =+ FileSystemT $ do+ path <- absify relativePath+ gets (deleteNode (splitDirectories path) . (^. fsRoot)) >>= \case+ Just newRoot -> fsRoot .= newRoot+ Nothing -> throwInterpretError "removeFile" ("No such file: " <> path)+ setCurrentDirectory relativePath =+ FileSystemT $ do+ path <- absify relativePath+ fsCurrentDirectory .= path+ writeFile relativePath contents =+ FileSystemT $ do+ path <- absify relativePath+ fsRoot . at path ?= File (takeFileName path) contents++runFileSystemT :: FSState -> FileSystemT m a -> ExceptT String m (a, FSState)+runFileSystemT origState (FileSystemT x) = runStateT x origState++runFileSystem :: FSState -> FileSystem a -> Either String (a, FSState)+runFileSystem origState x = runExcept $ runFileSystemT origState x
+ test/Axel/Test/Monad/FileSystemSpec.hs view
@@ -0,0 +1,74 @@+module Axel.Test.Monad.FileSystemSpec where++import qualified Axel.Monad.FileSystem as FS+import qualified Axel.Test.Monad.FileSystemMock as Mock++import Control.Lens++import System.FilePath++import Test.Tasty.Hspec++{-# ANN module "HLint: ignore Redundant do" #-}++spec_FileSystem :: SpecWith ()+spec_FileSystem = do+ describe "getDirectoryContentsRec" $ do+ it "gets the files inside a directory and all its subdirectories" $ do+ let action = FS.getDirectoryContentsRec "dir1"+ let origState =+ Mock.mkFSState+ [ Mock.Directory+ "dir1"+ [ Mock.File "file1" ""+ , Mock.Directory+ "dir2"+ [Mock.File "file2" "", Mock.Directory "dir3" []]+ ]+ ]+ let expected = ["dir1/file1", "dir1/dir2/file2"]+ case Mock.runFileSystem origState action of+ Left err -> expectationFailure err+ Right result -> result `shouldBe` (expected, origState)+ describe "withCurrentDirectory" $ do+ it "changes the directory and resets it afterwards" $ do+ let action = do+ FS.withCurrentDirectory "inside/subdir" $+ FS.writeFile "insideDir" "insideDirContents"+ FS.writeFile "outsideDir" "outsideDirContents"+ let origState =+ Mock.mkFSState+ [ Mock.Directory+ "inside"+ [ Mock.Directory "subdir" [Mock.File "bar" "barContents"]+ , Mock.File "foo" "fooContents"+ ]+ ]+ let expected =+ origState &+ (Mock.fsRoot . at "inside/subdir/insideDir" ?~+ Mock.File "insideDir" "insideDirContents") &+ (Mock.fsRoot . at "outsideDir" ?~+ Mock.File "outsideDir" "outsideDirContents")+ case Mock.runFileSystem origState action of+ Left err -> expectationFailure err+ Right result -> result `shouldBe` ((), expected)+ describe "withTemporaryDirectory" $ do+ it+ "creates a temporary directory and resets the current directory afterwards" $ do+ let action = do+ FS.withTemporaryDirectory $ \tempDir ->+ FS.writeFile (tempDir </> "insideTemp0") "insideTemp0Contents"+ FS.withTemporaryDirectory $ \tempDir ->+ FS.writeFile (tempDir </> "insideTemp1") "insideTemp1Contents"+ let origState = Mock.mkFSState []+ let expected =+ origState & (Mock.fsRoot . at "tmp" ?~ Mock.Directory "tmp" []) &+ (Mock.fsRoot . at "tmp/0" ?~+ Mock.Directory "0" [Mock.File "insideTemp0" "insideTemp0Contents"]) &+ (Mock.fsRoot . at "tmp/1" ?~+ Mock.Directory "1" [Mock.File "insideTemp1" "insideTemp1Contents"]) &+ (Mock.fsTempCounter .~ 2)+ case Mock.runFileSystem origState action of+ Left err -> expectationFailure err+ Right result -> result `shouldBe` ((), expected)
+ test/Axel/Test/Monad/ProcessMock.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Axel.Test.Monad.ProcessMock where++import Axel.Monad.Console as Console+import Axel.Monad.FileSystem as FS+import Axel.Monad.Process as Proc+import Axel.Monad.Resource as Res+import Axel.Test.MockUtils+import Axel.Test.Monad.FileSystemMock as Mock++import Control.Lens+import Control.Monad.Except+import Control.Monad.State.Lazy++import System.Exit++newtype ProcessResultT m =+ ProcessResultT ((ExitCode, Maybe (String, String)), Mock.FileSystemT m ())+ deriving (Eq, Show)++data ProcessStateT m = ProcessStateT+ { _procMockArgs :: [String]+ , _procExecutionLog :: [(String, [String], Maybe String)]+ , _procMockResults :: [ProcessResultT m]+ } deriving (Eq, Show)++makeFieldsNoPrefix ''ProcessStateT++type ProcessState = ProcessStateT Identity++mkProcessState :: [String] -> [ProcessResultT m] -> ProcessStateT m+mkProcessState mockArgs mockResults =+ ProcessStateT+ { _procMockArgs = mockArgs+ , _procExecutionLog = []+ , _procMockResults = mockResults+ }++newtype ProcessT m a =+ ProcessT (StateT (ProcessStateT m) (ExceptT String (Mock.FileSystemT m)) a)+ deriving ( Functor+ , Applicative+ , Monad+ , MonadConsole+ , MonadFileSystem+ , MonadResource+ )++type Process = ProcessT Identity++deriving instance+ (Eq+ (StateT (ProcessStateT m) (ExceptT String (Mock.FileSystemT m))+ a)) =>+ Eq (ProcessT m a)++deriving instance+ (Show+ (StateT (ProcessStateT m) (ExceptT String (Mock.FileSystemT m))+ a)) =>+ Show (ProcessT m a)++instance MonadTrans ProcessT where+ lift = ProcessT . lift . lift . lift++instance (Monad m) => MonadProcess (ProcessT m) where+ getArgs = ProcessT $ gets (^. procMockArgs)+ runProcess cmd args stdin =+ ProcessT $ do+ procExecutionLog %= (|> (cmd, args, Just stdin))+ gets (uncons . (^. procMockResults)) >>= \case+ Just (ProcessResultT (mockResult, fsAction), newMockResults) -> do+ procMockResults .= newMockResults+ case mockResult of+ (exitCode, Just (stdout, stderr)) ->+ lift (lift fsAction) >> pure (exitCode, stdout, stderr)+ _ ->+ throwInterpretError+ "RunProcess"+ ("Wrong type for mock result: " <> show mockResult)+ Nothing -> throwInterpretError "runProcess" "No mock result available"+ runProcessInheritingStreams cmd args =+ ProcessT $ do+ procExecutionLog %= (|> (cmd, args, Nothing))+ gets (uncons . (^. procMockResults)) >>= \case+ Just (ProcessResultT (mockResult, fsAction), newMockResults) -> do+ procMockResults .= newMockResults+ case mockResult of+ (exitCode, Nothing) -> pure fsAction >> pure exitCode+ _ ->+ throwInterpretError+ "runProcessInheritingStreams"+ ("Wrong type for mock result: " <> show mockResult)+ Nothing ->+ throwInterpretError+ "RunProcessInheritingStreams"+ "No mock result available"++runProcessT ::+ forall a m. (Monad m)+ => (ProcessStateT m, Mock.FSState)+ -> ProcessT m a+ -> ExceptT String m (a, (ProcessStateT m, Mock.FSState))+runProcessT (origState, origFSState) (ProcessT x) =+ ExceptT $+ runExceptT (runFileSystemT origFSState $ runExceptT $ runStateT x origState) <&> \case+ Left err -> Left err+ Right (x'', fsState) ->+ case x'' of+ Left err -> Left err+ Right (x''', procState) -> Right (x''', (procState, fsState))++runProcess ::+ (ProcessState, Mock.FSState)+ -> Process a+ -> Either String (a, (ProcessState, Mock.FSState))+runProcess origState x = runExcept $ runProcessT origState x
+ test/Axel/Test/Monad/ResourceMock.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Axel.Test.Monad.ResourceMock where++import Axel.Monad.Console as Console+import Axel.Monad.FileSystem as FS+import Axel.Monad.Process as Proc+import Axel.Monad.Resource as Res++import Control.Monad.Identity+import Control.Monad.Trans++import System.FilePath++newtype ResourceT m a =+ ResourceT (m a)+ deriving ( Functor+ , Applicative+ , Monad+ , MonadConsole+ , MonadFileSystem+ , MonadProcess+ )++type Resource = ResourceT Identity++instance MonadTrans ResourceT where+ lift = ResourceT++instance (Monad m) => MonadResource (ResourceT m) where+ getResourcePath (Res.ResourceId resourceId) =+ ResourceT $ pure ("resources" </> resourceId)++runResourceT :: ResourceT m a -> m a+runResourceT (ResourceT x) = x++runResource :: Resource a -> a+runResource = runIdentity . runResourceT
+ test/Axel/Test/Monad/ResourceSpec.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleContexts #-}++module Axel.Test.Monad.ResourceSpec where++import qualified Axel.Monad.Resource as Res+import qualified Axel.Test.Monad.FileSystemMock as Mock+import qualified Axel.Test.Monad.ResourceMock as Mock++import Test.Tasty.Hspec++{-# ANN module "HLint: ignore Redundant do" #-}++spec_Resource :: SpecWith ()+spec_Resource =+ describe "readResource" $ do+ it "reads a resource's contents from the file system" $ do+ let action = Res.readResource (Res.ResourceId "resGroup1/res1")+ let origFSState =+ Mock.mkFSState+ [ Mock.Directory+ "resources"+ [Mock.Directory "resGroup1" [Mock.File "res1" "res1Contents"]]+ ]+ let expected = "res1Contents"+ case Mock.runFileSystem origFSState $ Mock.runResourceT action of+ Left err -> expectationFailure err+ Right result -> result `shouldBe` (expected, origFSState)
+ test/Axel/Test/NormalizeSpec.hs view
@@ -0,0 +1,14 @@+module Axel.Test.NormalizeSpec where++import Axel.Denormalize+import Axel.Normalize+import Axel.Test.MockUtils+import qualified Axel.Test.Parse.ASTGen as Parse.ASTGen++import Hedgehog++hprop_denormalizeExpression_is_the_inverse_of_normalizeExpression :: Property+hprop_denormalizeExpression_is_the_inverse_of_normalizeExpression =+ property $ do+ expr <- forAll Parse.ASTGen.genExpression+ expr === denormalizeExpression (unwrapRight (normalizeExpression expr))
+ test/Axel/Test/Parse/ASTGen.hs view
@@ -0,0 +1,18 @@+module Axel.Test.Parse.ASTGen where++import qualified Axel.Parse.AST as AST++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++genExpression :: (MonadGen m) => m AST.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.SExpression <$> Gen.list (Range.linear 0 3) genExpression]
+ test/Axel/Test/ParseSpec.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE QuasiQuotes #-}++module Axel.Test.ParseSpec where++import Axel.Parse+import Axel.Test.MockUtils++import Test.Tasty.Hspec++spec_Parse :: SpecWith ()+spec_Parse = do+ describe "parseSingle" $ do+ it "can parse a character literal" $ do+ let result = LiteralChar 'a'+ case parseSingle "{a}" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can parse an integer literal" $ do+ let result = LiteralInt 123+ case parseSingle "123" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can parse a list literal" $ do+ let result = SExpression [Symbol "list", LiteralInt 1, LiteralChar 'a']+ case parseSingle "[1 {a}]" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can parse a string literal" $ do+ let result = LiteralString "a b"+ case parseSingle "\"a b\"" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can parse a quasiquoted expression" $ do+ let result =+ SExpression+ [Symbol "quasiquote", SExpression [Symbol "foo", Symbol "bar"]]+ case parseSingle "`(foo bar)" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can parse an s-expression" $ do+ let result = SExpression [Symbol "foo", Symbol "bar"]+ case parseSingle "(foo bar)" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can parse a splice-unquoted expression" $ do+ let result =+ SExpression+ [ Symbol "unquoteSplicing"+ , SExpression [Symbol "foo", Symbol "bar"]+ ]+ case parseSingle "~@(foo bar)" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can parse a symbol" $ do+ let result = Symbol "abc123'''"+ case parseSingle "abc123'''" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can parse an unquoted expression" $ do+ let result =+ SExpression+ [Symbol "unquote", SExpression [Symbol "foo", Symbol "bar"]]+ case parseSingle "~(foo bar)" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can quote a character character" $ do+ let result = SExpression [Symbol "AST.LiteralChar", LiteralChar 'a']+ case parseSingle "'{a}" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can quote an integer literal" $ do+ let result = SExpression [Symbol "AST.LiteralInt", LiteralInt 123]+ case parseSingle "'123" of+ 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 parseSingle "'[1 2]" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can quote a string literal" $ do+ let result = SExpression [Symbol "AST.LiteralString", LiteralString "foo"]+ case parseSingle "'\"foo\"" of+ 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 parseSingle "'(1 2)" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ it "can quote a symbol" $ do+ let result = SExpression [Symbol "AST.Symbol", LiteralString "foo"]+ case parseSingle "'foo" of+ 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"]+ ]+ ]+ case parseSingle "''foo" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result+ describe "parseMultiple" $ do+ it "can parse multiple expressions" $ do+ let input =+ [s|+(foo 1 2 3)++(bar+ x+ y+ z)+|]+ let result =+ [ SExpression+ [Symbol "foo", LiteralInt 1, LiteralInt 2, LiteralInt 3]+ , SExpression [Symbol "bar", Symbol "x", Symbol "y", Symbol "z"]+ ]+ case parseMultiple input of+ Left err -> expectationFailure $ show err+ Right x -> 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)+|]+ let result =+ SExpression+ [ Symbol "begin"+ , SExpression+ [Symbol "foo", LiteralInt 1, LiteralInt 2, LiteralInt 3]+ ]+ case parseSource input of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result
+ test/Main.hs view
@@ -0,0 +1,3 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}++module Main where