diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/axel.cabal b/axel.cabal --- a/axel.cabal +++ b/axel.cabal @@ -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 diff --git a/examples/axelTemp/Axel.hs b/examples/axelTemp/Axel.hs deleted file mode 100644 --- a/examples/axelTemp/Axel.hs +++ /dev/null @@ -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 diff --git a/examples/doNotation.axel b/examples/doNotation.axel deleted file mode 100644 --- a/examples/doNotation.axel +++ /dev/null @@ -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)))) diff --git a/examples/if.axel b/examples/if.axel deleted file mode 100644 --- a/examples/if.axel +++ /dev/null @@ -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...")))) diff --git a/scripts/test.sh b/scripts/test.sh new file mode 100644 --- /dev/null +++ b/scripts/test.sh @@ -0,0 +1,5 @@ +set -eu +set -o pipefail + +./scripts/build.sh +stack test diff --git a/src/Axel/AST.hs b/src/Axel/AST.hs --- a/src/Axel/AST.hs +++ b/src/Axel/AST.hs @@ -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 diff --git a/src/Axel/Denormalize.hs b/src/Axel/Denormalize.hs --- a/src/Axel/Denormalize.hs +++ b/src/Axel/Denormalize.hs @@ -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)] diff --git a/src/Axel/Eff/FileSystem.hs b/src/Axel/Eff/FileSystem.hs --- a/src/Axel/Eff/FileSystem.hs +++ b/src/Axel/Eff/FileSystem.hs @@ -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 = diff --git a/src/Axel/Haskell/File.hs b/src/Axel/Haskell/File.hs --- a/src/Axel/Haskell/File.hs +++ b/src/Axel/Haskell/File.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} diff --git a/src/Axel/Haskell/Language.hs b/src/Axel/Haskell/Language.hs new file mode 100644 --- /dev/null +++ b/src/Axel/Haskell/Language.hs @@ -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") + ] diff --git a/src/Axel/Haskell/Project.hs b/src/Axel/Haskell/Project.hs --- a/src/Axel/Haskell/Project.hs +++ b/src/Axel/Haskell/Project.hs @@ -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) diff --git a/src/Axel/Haskell/Stack.hs b/src/Axel/Haskell/Stack.hs --- a/src/Axel/Haskell/Stack.hs +++ b/src/Axel/Haskell/Stack.hs @@ -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) diff --git a/src/Axel/Macros.hs b/src/Axel/Macros.hs --- a/src/Axel/Macros.hs +++ b/src/Axel/Macros.hs @@ -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 diff --git a/src/Axel/Normalize.hs b/src/Axel/Normalize.hs --- a/src/Axel/Normalize.hs +++ b/src/Axel/Normalize.hs @@ -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 diff --git a/src/Axel/Parse.hs b/src/Axel/Parse.hs --- a/src/Axel/Parse.hs +++ b/src/Axel/Parse.hs @@ -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 = "()[]{}" diff --git a/src/Axel/Parse/Args.hs b/src/Axel/Parse/Args.hs --- a/src/Axel/Parse/Args.hs +++ b/src/Axel/Parse/Args.hs @@ -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 diff --git a/src/Axel/Utils/Display.hs b/src/Axel/Utils/Display.hs --- a/src/Axel/Utils/Display.hs +++ b/src/Axel/Utils/Display.hs @@ -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 diff --git a/src/Axel/Utils/Recursion.hs b/src/Axel/Utils/Recursion.hs --- a/src/Axel/Utils/Recursion.hs +++ b/src/Axel/Utils/Recursion.hs @@ -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 diff --git a/src/Axel/Utils/String.hs b/src/Axel/Utils/String.hs --- a/src/Axel/Utils/String.hs +++ b/src/Axel/Utils/String.hs @@ -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") diff --git a/test/Axel/Test/ASTGen.hs b/test/Axel/Test/ASTGen.hs --- a/test/Axel/Test/ASTGen.hs +++ b/test/Axel/Test/ASTGen.hs @@ -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 + ] diff --git a/test/Axel/Test/MockUtils.hs b/test/Axel/Test/MockUtils.hs --- a/test/Axel/Test/MockUtils.hs +++ b/test/Axel/Test/MockUtils.hs @@ -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 diff --git a/test/Axel/Test/ParseSpec.hs b/test/Axel/Test/ParseSpec.hs --- a/test/Axel/Test/ParseSpec.hs +++ b/test/Axel/Test/ParseSpec.hs @@ -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