axel 0.0.6 → 0.0.7
raw patch · 23 files changed
+496/−340 lines, 23 filesdep ~bytestringdep ~directorydep ~filepath
Dependency ranges changed: bytestring, directory, filepath, freer-simple, haskell-src-exts, lens, lens-aeson, optparse-applicative, parsec, process, regex-pcre, singletons, strict, template-haskell, text, typed-process, vector, yaml
Files
- app/Main.hs +3/−2
- axel.cabal +31/−31
- examples/axelTemp/Axel.hs +0/−46
- examples/doNotation.axel +0/−50
- examples/if.axel +0/−40
- scripts/test.sh +5/−0
- src/Axel/AST.hs +64/−3
- src/Axel/Denormalize.hs +48/−17
- src/Axel/Eff/FileSystem.hs +4/−33
- src/Axel/Haskell/File.hs +1/−0
- src/Axel/Haskell/Language.hs +42/−0
- src/Axel/Haskell/Project.hs +4/−4
- src/Axel/Haskell/Stack.hs +1/−4
- src/Axel/Macros.hs +28/−8
- src/Axel/Normalize.hs +67/−12
- src/Axel/Parse.hs +36/−29
- src/Axel/Parse/Args.hs +104/−31
- src/Axel/Utils/Display.hs +1/−5
- src/Axel/Utils/Recursion.hs +1/−1
- src/Axel/Utils/String.hs +15/−0
- test/Axel/Test/ASTGen.hs +30/−4
- test/Axel/Test/MockUtils.hs +0/−14
- test/Axel/Test/ParseSpec.hs +11/−6
app/Main.hs view
@@ -15,11 +15,12 @@ import qualified Axel.Eff.Resource as Effs (Resource) import Axel.Error (Error) import qualified Axel.Error as Error (runEff)-import Axel.Haskell.File (evalFile)+import Axel.Haskell.File (transpileFile') import Axel.Haskell.Project (buildProject, runProject) import Axel.Haskell.Stack (axelStackageVersion) import Axel.Parse.Args (Command(File, Project, Version), commandParser) +import Control.Monad (void) import Control.Monad.Freer (Eff) import qualified Control.Monad.Freer as Effs (runM) import qualified Control.Monad.Freer.Error as Effs (Error)@@ -35,7 +36,7 @@ Res.runEff . Proc.runEff . FS.runEff . Error.runEff . Console.runEff app :: Command -> AppEffs ()-app (File filePath) = evalFile filePath+app (File filePath) = void $ transpileFile' filePath app Project = buildProject >> runProject app Version = putStrLn $ "Axel version " <> axelStackageVersion
axel.cabal view
@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.0. -- -- see: https://github.com/sol/hpack ----- hash: 716ae6ec648d90a914b50e20a88b41dd9aee9dac2b091b5447034de826522e20+-- hash: cce804be215fd1ed190c4b586fd770ceb33b98df1eb7ad5087cc57bfae5cfad3 name: axel-version: 0.0.6+version: 0.0.7 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@@ -17,17 +19,14 @@ license: BSD3 license-file: LICENSE build-type: Simple-cabal-version: >= 1.10 extra-source-files:- examples/axelTemp/Axel.hs- examples/doNotation.axel- examples/if.axel README.org scripts/build.sh scripts/clean.sh scripts/format.sh scripts/ghcid.sh scripts/lint.sh+ scripts/test.sh data-files: resources/autogenerated/macros/AST.hs resources/macros/MacroDefinitionAndEnvironmentFooter.hs@@ -56,6 +55,7 @@ Axel.Eff.Resource Axel.Error Axel.Haskell.File+ Axel.Haskell.Language Axel.Haskell.Prettify Axel.Haskell.Project Axel.Haskell.Stack@@ -76,24 +76,25 @@ src ghc-options: -Wall -Wcpp-undef -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-simplifiable-class-constraints -Wmissing-import-lists 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- , freer-simple >=1.1.0.0 && <1.2- , haskell-src-exts >=1.20.2 && <1.21- , lens >=4.16.1 && <4.18- , lens-aeson >=1.0.2 && <1.1- , 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- , singletons >=2.4 && <2.6- , strict >=0.3.2 && <0.4- , text >=1.2.2 && <1.3- , typed-process >=0.2.2 && <0.3- , vector >=0.12.0 && <0.13- , yaml >=0.8.31 && <0.11+ base >=4.12 && <4.13+ , bytestring >=0.10.8+ , directory >=1.3+ , filepath >=1.4.1+ , freer-simple >=1.2.0.0+ , haskell-src-exts >=1.20.2+ , lens >=4.16.1+ , lens-aeson >=1.0.2+ , optparse-applicative >=0.14.2+ , parsec >=3.1.11+ , process >=1.6.1+ , regex-pcre >=0.94.4+ , singletons >=2.4+ , strict >=0.3.2+ , template-haskell >=2.14+ , text >=1.2.2+ , typed-process >=0.2.2+ , vector >=0.12.0+ , yaml >=0.8.31 default-language: Haskell2010 executable axel-exe@@ -105,9 +106,9 @@ 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- , freer-simple >=1.1.0.0 && <1.2- , optparse-applicative >=0.14.2 && <0.15+ , base >=4.12 && <4.13+ , freer-simple >=1.2.0.0+ , optparse-applicative >=0.14.2 default-language: Haskell2010 test-suite axel-test@@ -135,10 +136,10 @@ 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+ , base >=4.12 && <4.13 , bytestring , filepath- , freer-simple >=1.1.0.0 && <1.2+ , freer-simple >=1.2.0.0 , hedgehog , lens , split@@ -147,6 +148,5 @@ , tasty-golden , tasty-hedgehog , tasty-hspec- , template-haskell , transformers default-language: Haskell2010
− examples/axelTemp/Axel.hs
@@ -1,46 +0,0 @@--- 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 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.--- (Maybe all macros have the argument automatically `fromFix`-ed to make consumption simpler?)-data Expression- = LiteralChar Char- | LiteralInt Int- | LiteralString String- | SExpression [Expression]- | Symbol String- deriving (Eq, Show)---- ******************************--- Internal utilities--- ******************************-toAxel :: Expression -> String-toAxel (LiteralChar x ) = ['\\', x]-toAxel (LiteralInt x ) = show x-toAxel (LiteralString xs) = "\"" ++ xs ++ "\""-toAxel (SExpression xs) = "(" ++ unwords (map toAxel xs) ++ ")"-toAxel (Symbol x ) = x---- ******************************--- Macro definition utilities--- ******************************-{-# NOINLINE gensymCounter #-}-gensymCounter :: IORef Int-gensymCounter = unsafePerformIO $ newIORef 0--gensym :: IO Expression-gensym = do- suffix <- readIORef gensymCounter- let identifier = "aXEL_AUTOGENERATED_IDENTIFIER_" ++ show suffix- modifyIORef gensymCounter succ- pure $ Symbol identifier
− examples/doNotation.axel
@@ -1,50 +0,0 @@-(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/if.axel
@@ -1,40 +0,0 @@-(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..."))))
+ scripts/test.sh view
@@ -0,0 +1,5 @@+set -eu+set -o pipefail++./scripts/build.sh+stack test
src/Axel/AST.hs view
@@ -9,11 +9,12 @@ module Axel.AST where +import Axel.Haskell.Language (isOperator) import Axel.Utils.Display- ( Bracket(DoubleQuotes, Parentheses, SingleQuotes, SquareBrackets)+ ( Bracket(CurlyBraces, DoubleQuotes, Parentheses, SingleQuotes,+ SquareBrackets) , Delimiter(Commas, Newlines, Pipes, Spaces) , delimit- , isOperator , renderBlock , renderPragma , surround@@ -62,10 +63,16 @@ , _constructors :: [FunctionApplication] } deriving (Eq, Show) +data NewtypeDeclaration = NewtypeDeclaration+ { _typeDefinition :: TypeDefinition+ , _constructor :: FunctionApplication+ } deriving (Eq, Show)+ data FunctionDefinition = FunctionDefinition { _name :: Identifier , _arguments :: [Expression] , _body :: Expression+ , _whereBindings :: [FunctionDefinition] } deriving (Eq, Show) data Import@@ -118,6 +125,14 @@ , _imports :: ImportSpecification } deriving (Eq, Show) +newtype RecordDefinition = RecordDefinition+ { _bindings :: [(Identifier, Expression)]+ } deriving (Eq, Show)++newtype RecordType = RecordType+ { _fields :: [(Identifier, Expression)]+ } deriving (Eq, Show)+ data RestrictedImport = RestrictedImport { _moduleName :: Identifier , _imports :: ImportSpecification@@ -153,6 +168,8 @@ | ELetBlock LetBlock | ELiteral Literal | ERawExpression String+ | ERecordDefinition RecordDefinition+ | ERecordType RecordType deriving (Eq, Show) instance ToHaskell Expression where@@ -168,6 +185,8 @@ toHaskell (ELetBlock x) = toHaskell x toHaskell (ELiteral x) = toHaskell x toHaskell (ERawExpression x) = x+ toHaskell (ERecordDefinition x) = toHaskell x+ toHaskell (ERecordType x) = toHaskell x data Literal = LChar Char@@ -186,6 +205,7 @@ | SFunctionDefinition FunctionDefinition | SMacroDefinition MacroDefinition | SModuleDeclaration Identifier+ | SNewtypeDeclaration NewtypeDeclaration | SPragma Pragma | SQualifiedImport QualifiedImport | SRawStatement String@@ -205,6 +225,7 @@ toHaskell (SPragma x) = toHaskell x toHaskell (SMacroDefinition x) = toHaskell x toHaskell (SModuleDeclaration x) = "module " <> x <> " where"+ toHaskell (SNewtypeDeclaration x) = toHaskell x toHaskell (SQualifiedImport x) = toHaskell x toHaskell (SRawStatement x) = x toHaskell (SRestrictedImport x) = toHaskell x@@ -231,10 +252,16 @@ makeFieldsNoPrefix ''MacroDefinition +makeFieldsNoPrefix ''NewtypeDeclaration+ makeFieldsNoPrefix ''Pragma makeFieldsNoPrefix ''QualifiedImport +makeFieldsNoPrefix ''RecordDefinition++makeFieldsNoPrefix ''RecordType+ makeFieldsNoPrefix ''RestrictedImport makeFieldsNoPrefix ''TopLevel@@ -280,7 +307,9 @@ toHaskell (EIdentifier (fnDef ^. name)) <> " " <> delimit Spaces (map toHaskell (fnDef ^. arguments)) <> " = " <>- toHaskell (fnDef ^. body)+ toHaskell (fnDef ^. body) <>+ " where " <>+ renderBlock (map toHaskell (fnDef ^. whereBindings)) instance ToHaskell DataDeclaration where toHaskell :: DataDeclaration -> String@@ -293,6 +322,14 @@ where removeSurroundingParentheses = tail . init +instance ToHaskell NewtypeDeclaration where+ toHaskell :: NewtypeDeclaration -> String+ toHaskell newtypeDeclaration =+ "newtype " <> toHaskell (newtypeDeclaration ^. typeDefinition) <> " = " <>+ removeSurroundingParentheses (toHaskell (newtypeDeclaration ^. constructor))+ where+ removeSurroundingParentheses = tail . init+ instance ToHaskell Lambda where toHaskell :: Lambda -> String toHaskell lambda =@@ -326,6 +363,24 @@ alias <> toHaskell (qualifiedImport ^. imports) +instance ToHaskell RecordDefinition where+ toHaskell :: RecordDefinition -> String+ toHaskell recordDefinition =+ surround CurlyBraces $+ delimit Commas $+ map+ (\(var, val) -> var <> " = " <> toHaskell val)+ (recordDefinition ^. bindings)++instance ToHaskell RecordType where+ toHaskell :: RecordType -> String+ toHaskell recordDefinition =+ surround CurlyBraces $+ delimit Commas $+ map+ (\(field, ty) -> field <> " :: " <> toHaskell ty)+ (recordDefinition ^. fields)+ instance ToHaskell RestrictedImport where toHaskell :: RestrictedImport -> String toHaskell restrictedImport =@@ -388,6 +443,8 @@ LInt _ -> x LString _ -> x ERawExpression _ -> x+ ERecordDefinition _ -> x+ ERecordType _ -> x topDownFmap :: (Expression -> Expression) -> Expression -> Expression topDownFmap f x = case f x of@@ -414,6 +471,8 @@ LInt _ -> x LString _ -> x ERawExpression _ -> x+ ERecordDefinition _ -> x+ ERecordType _ -> x bottomUpTraverse :: (Monad m) => (Expression -> m Expression) -> Expression -> m Expression bottomUpTraverse f x =@@ -449,3 +508,5 @@ LInt _ -> pure x LString _ -> pure x ERawExpression _ -> pure x+ ERecordDefinition _ -> pure x+ ERecordType _ -> pure x
src/Axel/Denormalize.hs view
@@ -2,14 +2,16 @@ import Axel.AST ( Expression(ECaseBlock, EEmptySExpression, EFunctionApplication,- EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression)+ EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression,+ ERecordDefinition, ERecordType) , Import(ImportItem, ImportType) , ImportSpecification(ImportAll, ImportOnly) , Literal(LChar, LInt, LString) , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,- SModuleDeclaration, SPragma, SQualifiedImport, SRawStatement,- SRestrictedImport, STopLevel, STypeSignature, STypeSynonym,- STypeclassDefinition, STypeclassInstance, SUnrestrictedImport)+ SModuleDeclaration, SNewtypeDeclaration, SPragma, SQualifiedImport,+ SRawStatement, SRestrictedImport, STopLevel, STypeSignature,+ STypeSynonym, STypeclassDefinition, STypeclassInstance,+ SUnrestrictedImport) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor) , alias@@ -17,10 +19,12 @@ , bindings , body , constraints+ , constructor , constructors , definition , definitions , expr+ , fields , function , functionDefinition , imports@@ -31,6 +35,7 @@ , pragmaSpecification , signatures , typeDefinition+ , whereBindings ) import qualified Axel.Parse as Parse ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,@@ -81,7 +86,22 @@ LChar char -> Parse.LiteralChar char LInt int -> Parse.LiteralInt int LString string -> Parse.LiteralString string-denormalizeExpression (ERawExpression rawSource) = Parse.LiteralString rawSource+denormalizeExpression (ERawExpression rawSource) =+ Parse.SExpression [Parse.Symbol "raw", Parse.LiteralString rawSource]+denormalizeExpression (ERecordDefinition recordDefinition) =+ let denormalizedBindings =+ map+ (\(var, val) ->+ Parse.SExpression [Parse.Symbol var, denormalizeExpression val])+ (recordDefinition ^. bindings)+ in Parse.SExpression (Parse.Symbol "record" : denormalizedBindings)+denormalizeExpression (ERecordType recordType) =+ let denormalizedFields =+ map+ (\(field, ty) ->+ Parse.SExpression [Parse.Symbol field, denormalizeExpression ty])+ (recordType ^. fields)+ in Parse.SExpression (Parse.Symbol "recordType" : denormalizedFields) denormalizeImportSpecification :: ImportSpecification -> Parse.Expression denormalizeImportSpecification ImportAll = Parse.Symbol "all"@@ -105,22 +125,33 @@ (denormalizeExpression . EFunctionApplication) (dataDeclaration ^. constructors)) denormalizeStatement (SFunctionDefinition fnDef) =- Parse.SExpression- [ Parse.Symbol "="- , Parse.Symbol (fnDef ^. name)- , Parse.SExpression (map denormalizeExpression (fnDef ^. arguments))- , denormalizeExpression (fnDef ^. body)- ]+ Parse.SExpression $ Parse.Symbol "=" : Parse.Symbol (fnDef ^. name) :+ Parse.SExpression (map denormalizeExpression (fnDef ^. arguments)) :+ denormalizeExpression (fnDef ^. body) :+ map (denormalizeStatement . SFunctionDefinition) (fnDef ^. whereBindings) denormalizeStatement (SMacroDefinition macroDef) =+ Parse.SExpression $ Parse.Symbol "macro" :+ Parse.Symbol (macroDef ^. functionDefinition . name) : Parse.SExpression- [ Parse.Symbol "macro"- , Parse.Symbol (macroDef ^. functionDefinition . name)- , Parse.SExpression- (map denormalizeExpression (macroDef ^. functionDefinition . arguments))- , denormalizeExpression (macroDef ^. functionDefinition . body)- ]+ (map denormalizeExpression (macroDef ^. functionDefinition . arguments)) :+ denormalizeExpression (macroDef ^. functionDefinition . body) :+ map+ (denormalizeStatement . SFunctionDefinition)+ (macroDef ^. functionDefinition . whereBindings) denormalizeStatement (SModuleDeclaration identifier) = Parse.SExpression [Parse.Symbol "module", Parse.Symbol identifier]+denormalizeStatement (SNewtypeDeclaration newtypeDeclaration) =+ let denormalizedTypeDefinition =+ case newtypeDeclaration ^. typeDefinition of+ TypeConstructor typeConstructor ->+ denormalizeExpression $ EFunctionApplication typeConstructor+ ProperType properType -> Parse.Symbol properType+ in Parse.SExpression+ [ Parse.Symbol "newtype"+ , denormalizedTypeDefinition+ , denormalizeExpression $+ EFunctionApplication (newtypeDeclaration ^. constructor)+ ] denormalizeStatement (SPragma pragma) = Parse.SExpression [Parse.Symbol "pragma", Parse.LiteralString (pragma ^. pragmaSpecification)]
src/Axel/Eff/FileSystem.hs view
@@ -2,12 +2,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} module Axel.Eff.FileSystem where import Prelude hiding (readFile, writeFile)-import qualified Prelude (readFile, writeFile)+import qualified Prelude (writeFile) import Control.Monad (forM) import Control.Monad.Freer@@ -18,6 +19,7 @@ , interpretM , send )+import Control.Monad.Freer.TH (makeEffect) import qualified System.Directory ( copyFile@@ -44,38 +46,7 @@ SetCurrentDirectory :: FilePath -> FileSystem () WriteFile :: String -> FilePath -> FileSystem () -copyFile :: (Member FileSystem effs) => FilePath -> FilePath -> Eff effs ()-copyFile src dest = send $ CopyFile src dest--createDirectoryIfMissing ::- (Member FileSystem effs) => Bool -> FilePath -> Eff effs ()-createDirectoryIfMissing createParentDirs path =- send $ CreateDirectoryIfMissing createParentDirs path--doesDirectoryExist :: (Member FileSystem effs) => FilePath -> Eff effs Bool-doesDirectoryExist = send . DoesDirectoryExist--getCurrentDirectory :: (Member FileSystem effs) => Eff effs FilePath-getCurrentDirectory = send GetCurrentDirectory--getDirectoryContents ::- (Member FileSystem effs) => FilePath -> Eff effs [FilePath]-getDirectoryContents = send . GetDirectoryContents--getTemporaryDirectory :: (Member FileSystem effs) => Eff effs FilePath-getTemporaryDirectory = send GetTemporaryDirectory--readFile :: (Member FileSystem effs) => FilePath -> Eff effs String-readFile = send . ReadFile--removeFile :: (Member FileSystem effs) => FilePath -> Eff effs ()-removeFile = send . RemoveFile--setCurrentDirectory :: (Member FileSystem effs) => FilePath -> Eff effs ()-setCurrentDirectory = send . SetCurrentDirectory--writeFile :: (Member FileSystem effs) => String -> FilePath -> Eff effs ()-writeFile contents path = send $ WriteFile contents path+makeEffect ''FileSystem runEff :: (LastMember IO effs) => Eff (FileSystem ': effs) ~> Eff effs runEff =
src/Axel/Haskell/File.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}
+ src/Axel/Haskell/Language.hs view
@@ -0,0 +1,42 @@+module Axel.Haskell.Language where++import Data.Char (isSymbol)++-- https://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators+isOperator :: String -> Bool+isOperator = all $ \x -> isSymbol x || x `elem` map fst haskellOperatorSymbols++haskellOperatorSymbols :: [(Char, String)]+haskellOperatorSymbols =+ [ (':', "axelSymbolColon")+ , ('!', "axelSymbolBang")+ , ('#', "axelSymbolHash")+ , ('$', "axelSymbolDollar")+ , ('%', "axelSymbolPercent")+ , ('&', "axelSymbolAmpersand")+ , ('+', "axelSymbolPlus")+ , ('*', "axelSymbolAsterisk")+ , ('/', "axelSymbolSlash")+ , ('<', "axelSymbolLess")+ , ('>', "axelSymbolGreater")+ , ('=', "axelSymbolEquals")+ , ('\\', "axelSymbolBackslash")+ , ('@', "axelSymbolAt")+ , ('?', "axelSymbolQuestion")+ , ('^', "axelSymbolCaret")+ , ('-', "axelSymbolDash")+ , ('|', "axelSymbolPipe")+ , ('~', "axelSymbolTilde")+ ]++haskellSyntaxSymbols :: [(Char, String)]+haskellSyntaxSymbols =+ [ ('.', "axelSymbolDot")+ , (',', "axelSymbolComma")+ , (';', "axelSymbolSemicolon")+ , ('[', "axelSymbolLeftBracket")+ , (']', "axelSymbolRightBracket")+ , ('{', "axelSymbolLeftBrace")+ , ('}', "axelSymbolRightBrace")+ , ('`', "axelSymbolGrave")+ ]
src/Axel/Haskell/Project.hs view
@@ -19,12 +19,13 @@ import Axel.Haskell.File (transpileFile') import Axel.Haskell.Stack ( addStackDependency- , axelStackageSpecifier+ , axelStackageId , buildStackProject , createStackProject , runStackProject ) +import Control.Monad (void) import Control.Monad.Freer (Eff, Members) import qualified Control.Monad.Freer.Error as Effs (Error) @@ -41,7 +42,7 @@ -> Eff effs () newProject projectName = do createStackProject projectName- addStackDependency axelStackageSpecifier projectName+ addStackDependency axelStackageId projectName templatePath <- getResourcePath newProjectTemplate let copyAxel filePath = do copyFile@@ -64,9 +65,8 @@ => Eff effs () buildProject = do projectPath <- getCurrentDirectory- hsPaths <- transpileProject+ void $ transpileProject buildStackProject projectPath- mapM_ removeFile hsPaths runProject :: (Members '[ Effs.Console, Effs.Error Error, Effs.FileSystem, Effs.Process] effs)
src/Axel/Haskell/Stack.hs view
@@ -70,10 +70,7 @@ axelStackageVersion = showVersion version axelStackageId :: StackageId-axelStackageId = "axel-" <> showVersion version--axelStackageSpecifier :: StackageId-axelStackageSpecifier = "axel ==" <> axelStackageVersion+axelStackageId = "axel" getStackProjectTargets :: (Members '[ Effs.FileSystem, Effs.Process] effs)
src/Axel/Macros.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -10,9 +12,10 @@ import Axel.AST ( MacroDefinition , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,- SModuleDeclaration, SPragma, SQualifiedImport, SRawStatement,- SRestrictedImport, STopLevel, STypeSignature, STypeSynonym,- STypeclassInstance, SUnrestrictedImport)+ SModuleDeclaration, SNewtypeDeclaration, SPragma, SQualifiedImport,+ SRawStatement, SRestrictedImport, STopLevel, STypeSignature,+ STypeSynonym, STypeclassDefinition, STypeclassInstance,+ SUnrestrictedImport) , ToHaskell(toHaskell) , functionDefinition , name@@ -36,6 +39,11 @@ , macroScaffold ) import Axel.Error (Error(MacroError))+import Axel.Haskell.Language+ ( haskellOperatorSymbols+ , haskellSyntaxSymbols+ , isOperator+ ) import Axel.Haskell.Prettify (prettifyHaskell) import Axel.Haskell.Stack (interpretFile) import Axel.Normalize (normalizeStatement)@@ -44,9 +52,10 @@ Symbol) , parseMultiple , programToTopLevelExpressions+ , syntaxSymbols , topLevelExpressionsToProgram )-import Axel.Utils.Display (Delimiter(Newlines), delimit, isOperator)+import Axel.Utils.Display (Delimiter(Newlines), delimit) import Axel.Utils.Function (uncurry3) import Axel.Utils.Recursion (Recursive(bottomUpTraverse), exhaustM) import Axel.Utils.String (replace)@@ -60,10 +69,11 @@ import qualified Control.Monad.Freer.Error as Effs (Error) import Data.Function ((&))+import Data.List (foldl') import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as NE (head, map, toList) import Data.Semigroup ((<>))-import qualified Data.Text as T (isSuffixOf, pack)+import qualified Data.Text as T (isSuffixOf, pack, replace, singleton, unpack) import System.Exit (ExitCode(ExitFailure)) import System.FilePath ((</>))@@ -74,9 +84,17 @@ if isOperator oldName then "%%%%%%%%%%" else "_AXEL_AUTOGENERATED_MACRO_DEFINITION"- in if T.pack suffix `T.isSuffixOf` T.pack oldName- then oldName- else oldName <> suffix+ suffixedName =+ if T.pack suffix `T.isSuffixOf` T.pack oldName+ then oldName+ else oldName <> suffix+ in T.unpack $+ foldl'+ (\acc (old, new) -> T.replace (T.singleton old) (T.pack new) acc)+ (T.pack suffixedName)+ (filter+ (\(sym, _) -> sym `notElem` Parse.syntaxSymbols)+ (haskellSyntaxSymbols <> haskellOperatorSymbols)) hygenisizeMacroDefinition :: MacroDefinition -> MacroDefinition hygenisizeMacroDefinition macroDef =@@ -148,10 +166,12 @@ isStatementNonconflicting (SPragma _) = True isStatementNonconflicting (SMacroDefinition _) = True isStatementNonconflicting (SModuleDeclaration _) = False+isStatementNonconflicting (SNewtypeDeclaration _) = True isStatementNonconflicting (SQualifiedImport _) = True isStatementNonconflicting (SRawStatement _) = True isStatementNonconflicting (SRestrictedImport _) = True isStatementNonconflicting (STopLevel _) = False+isStatementNonconflicting (STypeclassDefinition _) = True isStatementNonconflicting (STypeclassInstance _) = True isStatementNonconflicting (STypeSignature _) = True isStatementNonconflicting (STypeSynonym _) = True
src/Axel/Normalize.hs view
@@ -8,7 +8,8 @@ ( CaseBlock(CaseBlock) , DataDeclaration(DataDeclaration) , Expression(ECaseBlock, EEmptySExpression, EFunctionApplication,- EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression)+ EIdentifier, ELambda, ELetBlock, ELiteral, ERawExpression,+ ERecordDefinition, ERecordType) , FunctionApplication(FunctionApplication) , FunctionDefinition(FunctionDefinition) , Identifier@@ -18,13 +19,17 @@ , LetBlock(LetBlock) , Literal(LChar, LInt, LString) , MacroDefinition(MacroDefinition)+ , NewtypeDeclaration(NewtypeDeclaration) , Pragma(Pragma) , QualifiedImport(QualifiedImport)+ , RecordDefinition(RecordDefinition)+ , RecordType(RecordType) , RestrictedImport(RestrictedImport) , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,- SModuleDeclaration, SPragma, SQualifiedImport, SRawStatement,- SRestrictedImport, STopLevel, STypeSignature, STypeSynonym,- STypeclassDefinition, STypeclassInstance, SUnrestrictedImport)+ SModuleDeclaration, SNewtypeDeclaration, SPragma, SQualifiedImport,+ SRawStatement, SRestrictedImport, STopLevel, STypeSignature,+ STypeSynonym, STypeclassDefinition, STypeclassInstance,+ SUnrestrictedImport) , TopLevel(TopLevel) , TypeDefinition(ProperType, TypeConstructor) , TypeSignature(TypeSignature)@@ -85,6 +90,30 @@ "`raw` takes strings representing the code to inject directly." [x, expr] in ERawExpression <$> normalizedRawSource+ Parse.Symbol "record":bindings ->+ let normalizedBindings =+ traverse+ (\x ->+ normalizeExpression x >>= \case+ EFunctionApplication (FunctionApplication (EIdentifier field) [val]) ->+ pure (field, val)+ _ ->+ throwError $+ NormalizeError "Invalid field binding!" [x, expr])+ bindings+ in ERecordDefinition <$> (RecordDefinition <$> normalizedBindings)+ Parse.Symbol "recordType":fields ->+ let normalizedFields =+ traverse+ (\x ->+ normalizeExpression x >>= \case+ EFunctionApplication (FunctionApplication (EIdentifier field) [ty]) ->+ pure (field, ty)+ _ ->+ throwError $+ NormalizeError "Invalid field definition!" [x, expr])+ fields+ in ERecordType <$> (RecordType <$> normalizedFields) fn:args -> EFunctionApplication <$> (FunctionApplication <$> normalizeExpression fn <*>@@ -94,13 +123,21 @@ normalizeFunctionDefinition :: (Member (Effs.Error Error) effs)- => Identifier+ => [Parse.Expression]+ -> Identifier -> [Parse.Expression] -> Parse.Expression+ -> [Parse.Expression] -> Eff effs FunctionDefinition-normalizeFunctionDefinition fnName arguments body =+normalizeFunctionDefinition ctx fnName arguments body whereDefs = FunctionDefinition fnName <$> traverse normalizeExpression arguments <*>- normalizeExpression body+ normalizeExpression body <*>+ traverse+ (\x ->+ normalizeStatement x >>= \case+ SFunctionDefinition funDef -> pure funDef+ _ -> throwError $ NormalizeError "Invalid where binding!" (x : ctx))+ whereDefs normalizeStatement :: (Member (Effs.Error Error) effs) => Parse.Expression -> Eff effs Statement@@ -108,8 +145,9 @@ case items of [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 "=":Parse.Symbol fnName:Parse.SExpression arguments:body:whereDefs ->+ SFunctionDefinition <$>+ normalizeFunctionDefinition [expr] fnName arguments body whereDefs Parse.Symbol "begin":stmts -> let normalizedStmts = traverse normalizeStatement stmts in STopLevel . TopLevel <$> normalizedStmts@@ -155,6 +193,23 @@ (DataDeclaration (ProperType properType) <$> normalizedConstructors) _ -> throwError $ NormalizeError "Invalid type!" [typeDef, expr]+ [Parse.Symbol "newtype", typeDef, constructor] ->+ let normalizedConstructor =+ normalizeExpression constructor >>= \case+ EFunctionApplication funApp -> pure funApp+ _ ->+ throwError $+ NormalizeError "Invalid type constructor!" [constructor, expr]+ in normalizeExpression typeDef >>= \case+ EFunctionApplication typeConstructor ->+ SNewtypeDeclaration <$>+ (NewtypeDeclaration (TypeConstructor typeConstructor) <$>+ normalizedConstructor)+ EIdentifier properType ->+ SNewtypeDeclaration <$>+ (NewtypeDeclaration (ProperType properType) <$>+ normalizedConstructor)+ _ -> throwError $ NormalizeError "Invalid type!" [typeDef, expr] [Parse.Symbol "import", Parse.Symbol moduleName, importSpec] -> SRestrictedImport <$> (RestrictedImport moduleName <$> normalizeImportSpec expr importSpec)@@ -177,9 +232,9 @@ normalizedDefs) [Parse.Symbol "pragma", Parse.LiteralString pragma] -> pure $ SPragma (Pragma pragma)- [Parse.Symbol "macro", Parse.Symbol macroName, Parse.SExpression arguments, body] ->+ Parse.Symbol "macro":Parse.Symbol macroName:Parse.SExpression arguments:body:whereBindings -> SMacroDefinition . MacroDefinition <$>- normalizeFunctionDefinition macroName arguments body+ normalizeFunctionDefinition [expr] macroName arguments body whereBindings [Parse.Symbol "module", Parse.Symbol moduleName] -> pure $ SModuleDeclaration moduleName [Parse.Symbol "raw", rawSource] ->@@ -196,7 +251,7 @@ let normalizedAlias = normalizeExpression alias normalizedDef = normalizeExpression def in STypeSynonym <$> (TypeSynonym <$> normalizedAlias <*> normalizedDef)- _ -> throwError $ NormalizeError "Invalid top-level form!" [expr]+ _ -> throwError $ NormalizeError "Invalid statement!" [expr] where normalizeImportSpec ctxt importSpec = case importSpec of
src/Axel/Parse.hs view
@@ -18,6 +18,7 @@ -- Re-exporting these so that consumers of parsed ASTs do not need -- to know about the internal file.+import Axel.Haskell.Language (haskellOperatorSymbols, haskellSyntaxSymbols) import Axel.Parse.AST ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression, Symbol)@@ -31,19 +32,15 @@ import Control.Monad.Freer.Error (throwError) import qualified Control.Monad.Freer.Error as Effs (Error) +import Data.Functor.Identity (Identity)+import Data.List ((\\))+ import Text.Parsec (ParsecT, Stream, (<|>), eof, parse, try)-import Text.Parsec.Char- ( alphaNum- , char- , digit- , letter- , noneOf- , oneOf- , space- , string- )+import Text.Parsec.Char (alphaNum, char, digit, noneOf, oneOf, space, string) import Text.Parsec.Combinator (many1, optional)+import Text.Parsec.Language (haskellDef) import Text.Parsec.Prim (many)+import Text.Parsec.Token (makeTokenParser, stringLiteral) -- TODO `Expression` should probably instead be an instance of `Traversable`, use recursion schemes, etc. -- If so, should I provide `toFix` and `fromFix` functions for macros to take advantage of?@@ -77,8 +74,7 @@ SExpression xs -> SExpression (map (topDownFmap f) xs) Symbol _ -> x -parseReadMacro ::- (Stream s m Char) => String -> String -> ParsecT s u m Expression+parseReadMacro :: String -> String -> ParsecT String u Identity Expression parseReadMacro prefix wrapper = applyWrapper <$> (string prefix *> expression) where applyWrapper x = SExpression [Symbol wrapper, x]@@ -90,45 +86,52 @@ whitespace = many space literalChar :: (Stream s m Char) => ParsecT s u m Expression-literalChar = LiteralChar <$> (char '{' *> any' <* char '}')+literalChar = LiteralChar <$> (string "#\\" *> any') 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 :: ParsecT String u Identity Expression literalList = SExpression . (Symbol "list" :) <$> (char '[' *> many item <* char ']') where item = try (whitespace *> expression) <|> expression -literalString :: (Stream s m Char) => ParsecT s u m Expression-literalString = LiteralString <$> (char '"' *> many (noneOf "\"") <* char '"')+literalString :: ParsecT String u Identity Expression+literalString = LiteralString <$> stringLiteral (makeTokenParser haskellDef) -quasiquotedExpression :: (Stream s m Char) => ParsecT s u m Expression+quasiquotedExpression :: ParsecT String u Identity Expression quasiquotedExpression = parseReadMacro "`" "quasiquote" -quotedExpression :: (Stream s m Char) => ParsecT s u m Expression+quotedExpression :: ParsecT String u Identity Expression quotedExpression = parseReadMacro "'" "quote" -sExpression :: (Stream s m Char) => ParsecT s u m Expression-sExpression = SExpression <$> (char '(' *> many item <* char ')')- where- item = try (whitespace *> expression) <|> expression+sExpressionItem :: ParsecT String u Identity Expression+sExpressionItem = try (whitespace *> expression) <|> expression -spliceUnquotedExpression :: (Stream s m Char) => ParsecT s u m Expression+sExpression :: ParsecT String u Identity Expression+sExpression = SExpression <$> (char '(' *> many sExpressionItem <* char ')')++infixSExpression :: ParsecT String u Identity Expression+infixSExpression =+ SExpression . (Symbol "applyInfix" :) <$>+ (char '{' *> many sExpressionItem <* char '}')++spliceUnquotedExpression :: ParsecT String u Identity Expression spliceUnquotedExpression = parseReadMacro "~@" "unquoteSplicing" -symbol :: (Stream s m Char) => ParsecT s u m Expression+symbol :: (Stream s Identity Char) => ParsecT s u Identity Expression symbol = Symbol <$>- ((:) <$> (letter <|> validSymbol) <*> many (alphaNum <|> validSymbol))- where- validSymbol = oneOf "!@#$%^&*-=~_+,./<>?\\|':"+ many1+ (alphaNum <|> oneOf "'_" <|>+ oneOf (map fst haskellSyntaxSymbols \\ syntaxSymbols) <|>+ oneOf (map fst haskellOperatorSymbols)) -unquotedExpression :: (Stream s m Char) => ParsecT s u m Expression+unquotedExpression :: ParsecT String u Identity Expression unquotedExpression = parseReadMacro "~" "unquote" -expression :: (Stream s m Char) => ParsecT s u m Expression+expression :: ParsecT String u Identity Expression expression = literalChar <|> literalInt <|> literalList <|> literalString <|> quotedExpression <|>@@ -136,6 +139,7 @@ try spliceUnquotedExpression <|> unquotedExpression <|> sExpression <|>+ infixSExpression <|> symbol -- TODO Derive this with Template Haskell (it's really brittle, currently).@@ -195,3 +199,6 @@ topLevelExpressionsToProgram :: [Expression] -> Expression topLevelExpressionsToProgram stmts = SExpression (Symbol "begin" : stmts)++syntaxSymbols :: String+syntaxSymbols = "()[]{}"
src/Axel/Parse/Args.hs view
@@ -1,37 +1,110 @@ module Axel.Parse.Args where-+import Axel.Parse.AST as AST import Data.Semigroup ((<>))- import Options.Applicative- ( Parser- , argument- , command- , info- , metavar- , progDesc- , str- , subparser- )+ (Parser, argument, command, info, metavar, progDesc, str,+ subparser) -data Command- = File FilePath- | Project- | Version+mdo' :: ((->) ([] AST.Expression) AST.Expression)+mdo' ((:) var ((:) (AST.Symbol "<-") ((:) val rest)))+ = (AST.SExpression+ (concat+ [[(AST.Symbol ">>=")], [val],+ [(AST.SExpression+ (concat+ [[(AST.Symbol "\\")], [(AST.SExpression (concat [[var]]))],+ [(mdo' rest)]]))]]))+ where+mdo' ((:) val rest)+ = (case rest of+ [] -> val+ _ -> (AST.SExpression+ (concat [[(AST.Symbol ">>")], [val], [(mdo' rest)]])))+ where -commandParser :: Parser Command-commandParser = subparser $ projectCommand <> fileCommand <> versionCommand+data Command = File FilePath+ | Project+ | Version++commandParser :: (Parser Command)+commandParser+ = (subparser+ ((<>) projectCommand ((<>) fileCommand versionCommand)))+ where fileCommand+ = (command "file"+ (info ((<$>) File (argument str (metavar "FILE")))+ (progDesc "Build and run a single file")))+ where+ projectCommand+ = (command "project"+ (info (pure Project) (progDesc "Build and run the project")))+ where+ versionCommand+ = (command "version"+ (info (pure Version)+ (progDesc "Display the version of the Axel compiler")))+ where+quasiquote_AXEL_AUTOGENERATED_MACRO_DEFINITION+ [(AST.SExpression xs)]+ = (let quasiquoteElem+ = (\ x ->+ (case x of+ (AST.SExpression [(AST.Symbol "unquote"), x]) -> (AST.SExpression+ [(AST.Symbol "list"), x])+ (AST.SExpression+ [(AST.Symbol "unquoteSplicing"), x]) -> (AST.SExpression+ [(AST.Symbol+ "AST.toExpressionList"),+ x])+ atom -> (AST.SExpression+ [(AST.Symbol "list"),+ (AST.SExpression [(AST.Symbol "quasiquote"), atom])])))+ in+ (pure+ [(AST.SExpression+ [(AST.Symbol "AST.SExpression"),+ (AST.SExpression+ [(AST.Symbol "concat"),+ (AST.SExpression+ ((:) (AST.Symbol "list") (map quasiquoteElem xs)))])])])) where- 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")- versionCommand =- command- "version"- (info (pure Version) $- progDesc "Display the version of the Axel compiler")+quasiquote_AXEL_AUTOGENERATED_MACRO_DEFINITION [atom]+ = (pure [(AST.SExpression [(AST.Symbol "quote"), atom])])+ where+applyInfix_AXEL_AUTOGENERATED_MACRO_DEFINITION [x, op, y]+ = (pure [(AST.SExpression (concat [[op], [x], [y]]))])+ where+fnCase_AXEL_AUTOGENERATED_MACRO_DEFINITION cases+ = ((<$>)+ (\ varId ->+ [(AST.SExpression+ (concat+ [[(AST.Symbol "\\")], [(AST.SExpression (concat [[varId]]))],+ [(AST.SExpression+ (concat+ [[(AST.Symbol "case")], [varId],+ (AST.toExpressionList cases)]))]]))])+ AST.gensym)+ where+def_AXEL_AUTOGENERATED_MACRO_DEFINITION+ ((:) name ((:) typeSig cases))+ = (pure+ ((:)+ (AST.SExpression (concat [[(AST.Symbol "::")], [name], [typeSig]]))+ (map+ (\ x ->+ (AST.SExpression+ (concat [[(AST.Symbol "=")], [name], (AST.toExpressionList x)])))+ cases)))+ where+mdo_AXEL_AUTOGENERATED_MACRO_DEFINITION input+ = (pure [(mdo' input)])+ where+if_AXEL_AUTOGENERATED_MACRO_DEFINITION [cond, true, false]+ = (pure+ [(AST.SExpression+ (concat+ [[(AST.Symbol "case")], [cond],+ [(AST.SExpression (concat [[(AST.Symbol "True")], [true]]))],+ [(AST.SExpression (concat [[(AST.Symbol "False")], [false]]))]]))])+ where
src/Axel/Utils/Display.hs view
@@ -1,6 +1,6 @@ module Axel.Utils.Display where -import Data.Char (isSymbol, toLower, toUpper)+import Data.Char (toLower, toUpper) import Data.List (intercalate) import Data.Semigroup ((<>)) @@ -19,10 +19,6 @@ lookupDelimiter Pipes = "|" lookupDelimiter Semicolons = ";" lookupDelimiter Spaces = " "---- https://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators-isOperator :: String -> Bool-isOperator = all $ \x -> isSymbol x || x `elem` "!#$%&*+.,/<=>?@\\^|-~:" lowerFirst :: String -> String lowerFirst (x:xs) = toLower x : xs
src/Axel/Utils/Recursion.hs view
@@ -11,6 +11,6 @@ class Recursive a where bottomUpFmap :: (a -> a) -> a -> a -- TODO Remove dependency on `Monad` in favor of `Applicative`- -- (which is all the standard `traverse` requires).+ -- (which is all that the standard `traverse` requires). bottomUpTraverse :: (Monad m) => (a -> m a) -> a -> m a topDownFmap :: (a -> a) -> a -> a
src/Axel/Utils/String.hs view
@@ -1,7 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+ module Axel.Utils.String where import qualified Data.Text as T (pack, replace, unpack) +import GHC.Exts (IsString(fromString))++import Language.Haskell.TH.Quote (QuasiQuoter(QuasiQuoter))+ replace :: String -> String -> String -> String replace needle replacement haystack = T.unpack $ T.replace (T.pack needle) (T.pack replacement) (T.pack haystack)++-- Adapted from http://hackage.haskell.org/package/string-quote-0.0.1/docs/src/Data-String-Quote.html#s.+s :: QuasiQuoter+s =+ QuasiQuoter+ ((\a -> [|fromString a|]) . filter (/= '\r'))+ (error "Cannot use s as a pattern")+ (error "Cannot use s as a type")+ (error "Cannot use s as a dec")
test/Axel/Test/ASTGen.hs view
@@ -37,6 +37,19 @@ Gen.list (Range.linear 0 3) ((,) <$> genExpression <*> genExpression) <*> genExpression +genRawExpression :: (MonadGen m) => m String+genRawExpression = Gen.string (Range.linear 0 10) Gen.unicode++genRecordDefinition :: (MonadGen m) => m AST.RecordDefinition+genRecordDefinition =+ AST.RecordDefinition <$>+ Gen.list (Range.linear 0 3) ((,) <$> genIdentifier <*> genExpression)++genRecordType :: (MonadGen m) => m AST.RecordType+genRecordType =+ AST.RecordType <$>+ Gen.list (Range.linear 0 3) ((,) <$> genIdentifier <*> genExpression)+ genExpression :: (MonadGen m) => m AST.Expression genExpression = Gen.recursive@@ -47,6 +60,9 @@ , AST.ELambda <$> genLambda , AST.ELetBlock <$> genLetBlock , AST.ELiteral <$> genLiteral+ , AST.ERawExpression <$> genRawExpression+ , AST.ERecordDefinition <$> genRecordDefinition+ , AST.ERecordType <$> genRecordType ] genTypeDefinition :: (MonadGen m) => m AST.TypeDefinition@@ -65,7 +81,8 @@ genFunctionDefinition = AST.FunctionDefinition <$> genIdentifier <*> Gen.list (Range.linear 0 3) genExpression <*>- genExpression+ genExpression <*>+ Gen.list (Range.linear 0 3) genFunctionDefinition genPragma :: (MonadGen m) => m AST.Pragma genPragma = AST.Pragma <$> Gen.string (Range.linear 0 10) Gen.ascii@@ -93,6 +110,13 @@ AST.QualifiedImport <$> genIdentifier <*> genIdentifier <*> genImportSpecification +genNewtypeDeclaration :: (MonadGen m) => m AST.NewtypeDeclaration+genNewtypeDeclaration =+ AST.NewtypeDeclaration <$> genTypeDefinition <*> genFunctionApplication++genRawStatement :: (MonadGen m) => m String+genRawStatement = Gen.string (Range.linear 0 10) Gen.unicode+ genRestrictedImport :: (MonadGen m) => m AST.RestrictedImport genRestrictedImport = AST.RestrictedImport <$> genIdentifier <*> genImportSpecification@@ -122,11 +146,10 @@ Gen.recursive Gen.choice [ AST.SDataDeclaration <$> genDataDeclaration- , AST.SFunctionDefinition <$> genFunctionDefinition , AST.SPragma <$> genPragma- , AST.SMacroDefinition <$> genMacroDefinition , AST.SModuleDeclaration <$> genIdentifier , AST.SQualifiedImport <$> genQualifiedImport+ , AST.SRawStatement <$> genRawStatement , AST.SRestrictedImport <$> genRestrictedImport , AST.STypeclassDefinition <$> genTypeclassDefinition , AST.STypeclassInstance <$> genTypeclassInstance@@ -134,4 +157,7 @@ , AST.STypeSynonym <$> genTypeSynonym , AST.SUnrestrictedImport <$> genIdentifier ]- [AST.STopLevel <$> genTopLevel]+ [ AST.STopLevel <$> genTopLevel+ , AST.SFunctionDefinition <$> genFunctionDefinition+ , AST.SMacroDefinition <$> genMacroDefinition+ ]
test/Axel/Test/MockUtils.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} module Axel.Test.MockUtils where@@ -12,10 +11,6 @@ import Control.Monad.Freer.Error as Effs import Control.Monad.Freer.State as Effs -import GHC.Exts (IsString(fromString))--import Language.Haskell.TH.Quote- throwInterpretError :: forall s effs a. (Members '[ Effs.Error String, Effs.State s] effs, Show s) => String@@ -29,15 +24,6 @@ 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/ParseSpec.hs view
@@ -5,7 +5,7 @@ import Axel.Error import Axel.Parse-import Axel.Test.MockUtils+import Axel.Utils.String import Control.Monad.Freer as Eff import qualified Control.Monad.Freer.Error as Effs@@ -19,7 +19,7 @@ describe "parseSingle" $ do it "can parse a character literal" $ do let result = LiteralChar 'a'- case Eff.run . Effs.runError @Error $ parseSingle "{a}" of+ case Eff.run . Effs.runError @Error $ parseSingle "#\\a" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse an integer literal" $ do@@ -29,12 +29,12 @@ Right x -> x `shouldBe` result it "can parse a list literal" $ do let result = SExpression [Symbol "list", LiteralInt 1, LiteralChar 'a']- case Eff.run . Effs.runError @Error $ parseSingle "[1 {a}]" of+ case Eff.run . Effs.runError @Error $ 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 Eff.run . Effs.runError @Error $ parseSingle "\"a b\"" of+ let result = LiteralString "a \"b"+ case Eff.run . Effs.runError @Error $ parseSingle "\"a \\\"b\"" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can parse a quasiquoted expression" $ do@@ -63,6 +63,11 @@ case Eff.run . Effs.runError @Error $ parseSingle "abc123'''" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result+ it "can parse a macro name" $ do+ let result = Symbol ",;foo"+ case Eff.run . Effs.runError @Error $ parseSingle ",;foo" of+ Left err -> expectationFailure $ show err+ Right x -> x `shouldBe` result it "can parse an unquoted expression" $ do let result = SExpression@@ -72,7 +77,7 @@ Right x -> x `shouldBe` result it "can quote a character character" $ do let result = SExpression [Symbol "AST.LiteralChar", LiteralChar 'a']- case Eff.run . Effs.runError @Error $ parseSingle "'{a}" of+ case Eff.run . Effs.runError @Error $ parseSingle "'#\\a" of Left err -> expectationFailure $ show err Right x -> x `shouldBe` result it "can quote an integer literal" $ do