diff --git a/.gitignore b/.gitignore index 71b4eb8..5d07542 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,5 @@ cabal.sandbox.config cabal.project.local .HTF/ .ghc.environment.* + +resources/autogenerated/* diff --git a/README.md b/README.md index 243f605..59b89f3 100644 --- a/README.md +++ b/README.md @@ -18,6 +18,13 @@ But, there's nothing (that I'm aware of) for all three. Hence, meet Lihsp! It's a Lisp-like language (with macros and all) that transpiles to Eta, fulfilling all the requirements listed above. :tada: +## TODO + + - [ ] Cleanup + - [ ] Use qualified imports + - [ ] Standardize use of `($)` + - [ ] Rename `AST` to `Target` (?) and `Parse` to `Lisp` (?) + ## Future Plans - Finish the JVM backend - Add a PureScript backend as well (or maybe first, instead of targeting the JVM initially) to alternatively take advantage of the JavaScript ecosystem. diff --git a/lihsp.cabal b/lihsp.cabal index 4eb7963..17f5148 100644 --- a/lihsp.cabal +++ b/lihsp.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 596fc166e921fb1d089e6c0008a31999fb69a79ec742eb8f8582f5c30b048f6a +-- hash: a29ef77f7e9aefca0e574bb8c6b5da0949c57ca81f4668850a02116c3b1a64d0 name: lihsp version: 0.1.0.0 @@ -20,11 +20,11 @@ cabal-version: >= 1.10 extra-source-files: README.md scripts/build.sh + scripts/clean.sh data-files: + resources/autogenerated/macros/Header.hs resources/macros/Footer.hs - resources/macros/Header.hs - resources/macros/Imports.hs source-repository head type: git @@ -55,6 +55,7 @@ library Lihsp.Utils.Display Lihsp.Utils.Recursion Lihsp.Utils.Resources + Lihsp.Utils.String other-modules: Paths_lihsp default-language: Haskell2010 diff --git a/resources/macros/Footer.hs b/resources/macros/Footer.hs index aa3d9d3..418cb96 100644 --- a/resources/macros/Footer.hs +++ b/resources/macros/Footer.hs @@ -1,4 +1,4 @@ %%%MACRO_DEFINITION%%% main :: IO () -main = aUTOGENERATED_MACRO_FUNCTION %%%%ARGUMENTS%%% >>= print +main = %%%MACRO_NAME%%% %%%ARGUMENTS%%% >>= print diff --git a/resources/macros/Header.hs b/resources/macros/Header.hs deleted file mode 100644 index 524333c..0000000 --- a/resources/macros/Header.hs +++ /dev/null @@ -1,23 +0,0 @@ -import System.Environment (getArgs) -{-# LANGUAGE InstanceSigs #-} - --- NOTE Because this file will be used as the header of auto-generated macro programs, --- it can't have any project-specific dependencies. -module Lihsp.Parse.AST where - -import Data.Semigroup ((<>)) - -data Expression - = LiteralChar Char - | LiteralInt Int - | LiteralList [Expression] - | SExpression [Expression] - | Symbol String - -instance Show Expression where - show :: Expression -> String - show (LiteralChar x) = ['\'', x, '\''] - show (LiteralInt x) = show x - show (LiteralList xs) = "[" <> unwords (map show xs) <> "]" - show (SExpression xs) = "(" <> unwords (map show xs) <> ")" - show (Symbol x) = x diff --git a/resources/macros/Imports.hs b/resources/macros/Imports.hs deleted file mode 100644 index e5bc688..0000000 --- a/resources/macros/Imports.hs +++ /dev/null @@ -1 +0,0 @@ -import System.Environment (getArgs) diff --git a/scripts/build.sh b/scripts/build.sh old mode 100644 new mode 100755 index b32b3e2..8b1dcd2 --- a/scripts/build.sh +++ b/scripts/build.sh @@ -2,8 +2,8 @@ set -eu set -o pipefail echo "Copying macro header..." -cat resources/macros/Imports.hs > resources/macros/Header.hs -cat src/Lihsp/Parse/AST.hs >> resources/macros/Header.hs +mkdir -p resources/autogenerated/macros +cp src/Lihsp/Parse/AST.hs resources/autogenerated/macros/Header.hs echo "Macro header copied!" stack build diff --git a/scripts/clean.sh b/scripts/clean.sh new file mode 100755 index 0000000..c0163a8 --- /dev/null +++ b/scripts/clean.sh @@ -0,0 +1,8 @@ +set -eu +set -o pipefail + +echo "Cleaning autogenerated resources..." +rm -rf resources/autogenerated +echo "Autogenerated resources cleaned!" + +stack clean diff --git a/src/Lihsp/AST.hs b/src/Lihsp/AST.hs index 5efa80c..e47205b 100644 --- a/src/Lihsp/AST.hs +++ b/src/Lihsp/AST.hs @@ -139,6 +139,7 @@ data Literal = LChar Char | LInt Int | LList [Expression] + | LSymbol Identifier deriving (Eq) instance Show Literal where @@ -146,6 +147,7 @@ instance Show Literal where show (LInt int) = show int show (LChar char) = surround SingleQuotes [char] show (LList list) = surround SquareBrackets $ delimit Commas (map show list) + show (LSymbol symbol) = "Literal (LSymbol \"" <> symbol <> "\")" data Statement = SDataDeclaration DataDeclaration @@ -238,7 +240,7 @@ instance Show MacroDefinition where show :: MacroDefinition -> String show macroDefinition = delimit Newlines $ - macroDefinition ^. name : + (macroDefinition ^. name <> " :: [Expression] -> [Expression]") : map (showFunctionDefinition $ macroDefinition ^. name) (macroDefinition ^. definitions) @@ -267,23 +269,3 @@ instance Show TypeSynonym where show typeSynonym = "type " <> show (typeSynonym ^. alias) <> " = " <> show (typeSynonym ^. definition) - --- TODO Either replace with `MonoTraversable` or make `Expression` polymorphic --- (in which case, use `Traversable`, recursion schemes, etc.). The latter --- would be preferable. --- TODO Remove the dependency on `Monad` (since the standard `traverse` only --- requires an `Applicative` instance). -traverseExpression :: - (Monad m) => (Expression -> m Expression) -> Expression -> m Expression -traverseExpression f x = - case x of - EFunctionApplication functionApplication -> - let newArguments = - traverse (traverseExpression f) (functionApplication ^. arguments) - newFunction = traverseExpression f (functionApplication ^. function) - in f =<< - (EFunctionApplication <$> - (FunctionApplication <$> newFunction <*> newArguments)) - EIdentifier _ -> f x - ELetBlock _ -> f x - ELiteral _ -> f x diff --git a/src/Lihsp/Eval.hs b/src/Lihsp/Eval.hs index c038d41..72f37a1 100644 --- a/src/Lihsp/Eval.hs +++ b/src/Lihsp/Eval.hs @@ -31,6 +31,6 @@ execInterpreter fileName = do evalSource :: (MonadError Error m, MonadIO m) => String -> m String evalSource source = - withTempFile "TempMaro.hs" $ \fileName handle -> do + withTempFile "TempEval.hs" $ \fileName handle -> do liftIO $ hPutStr handle source execInterpreter fileName diff --git a/src/Lihsp/Macros.hs b/src/Lihsp/Macros.hs index 9d0e888..6f14509 100644 --- a/src/Lihsp/Macros.hs +++ b/src/Lihsp/Macros.hs @@ -1,57 +1,84 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module Lihsp.Macros where -import Control.Lens.Operators ((.~)) -import Control.Monad.Except (MonadError) +import Control.Lens.Operators ((^.)) +import Control.Monad.Except (MonadError, throwError) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Function ((&)) import Data.Semigroup ((<>)) -import Data.Text (pack, replace, unpack) -import Lihsp.AST (Expression, MacroDefinition, name, traverseExpression) +import Lihsp.AST (name) +import qualified Lihsp.AST as AST (MacroDefinition) import Lihsp.Error (Error(MacroError)) import Lihsp.Eval (evalSource) -import qualified Lihsp.Parse as Parse (Expression) -import Lihsp.Parse (parseProgram) +import qualified Lihsp.Parse as Parse + ( Expression(LiteralChar, LiteralInt, SExpression, Symbol) + , parseProgram + ) +import Lihsp.Utils.Recursion (Recursive(bottomUpTraverse)) import Lihsp.Utils.Resources (readDataFile) +import Lihsp.Utils.String (replace) generateMacroProgram :: - (MonadIO m) => MacroDefinition -> [Expression] -> m String -generateMacroProgram macroDefinition applicationArguments = do - fileHeader <- liftIO $ readDataFile "resources/macros/Header.hs" - fileFooter <- liftIO getFileFooter - return $ fileHeader <> show fileContents <> fileFooter + (MonadIO m) => AST.MacroDefinition -> [Parse.Expression] -> m String +generateMacroProgram macroDefinition applicationArguments = + (<>) <$> liftIO getFileHeader <*> liftIO getFileFooter where + getFileHeader = readDataFile "autogenerated/macros/Header.hs" getFileFooter = let insertApplicationArguments = let applicationArgumentsPlaceholder = "%%%ARGUMENTS%%%" - in unpack . - replace + in replace applicationArgumentsPlaceholder - (pack $ show applicationArguments) . - pack + (show applicationArguments) insertDefinitionBody = let definitionBodyPlaceholder = "%%%MACRO_DEFINITION%%%" - in unpack . - replace definitionBodyPlaceholder (pack $ show macroDefinition) . - pack - in insertApplicationArguments . insertDefinitionBody <$> - readDataFile "resources/macros/Footer.hs" + in replace definitionBodyPlaceholder (show macroDefinition) + insertDefinitionName = + let definitionNamePlaceholder = "%%%MACRO_NAME%%%" + in replace definitionNamePlaceholder (macroDefinition ^. name) + in insertApplicationArguments . + insertDefinitionName . insertDefinitionBody <$> + readDataFile "macros/Footer.hs" -expandMacroCall :: +expandMacros :: (MonadError Error m, MonadIO m) - => MacroDefinition - -> [Expression] - -> m [Parse.Expression] -expandMacroCall macroDefinition args = - generateMacroProgram macroDefinition args >>= evalSource >>= parseProgram + => [AST.MacroDefinition] + -> Parse.Expression + -> m Parse.Expression +expandMacros environment = + bottomUpTraverse $ \expression -> + case expression of + Parse.LiteralChar _ -> return expression + Parse.LiteralInt _ -> return expression + Parse.SExpression functionApplication -> + lookupMacroDefinition environment (head functionApplication) >>= \case + Just macroDefinition -> + Parse.SExpression <$> + expandMacroApplication macroDefinition (tail functionApplication) + Nothing -> return expression + Parse.Symbol _ -> return expression + where + expandMacroApplication macroDefinition args = + generateMacroProgram macroDefinition args >>= evalSource >>= + Parse.parseProgram -expandMacros :: Expression -> IO Expression -expandMacros = - traverseExpression $ \expression -> - case macroApplication expression of - Just (macroName, arguments) -> expandMacroCall - Nothing -> return expression +lookupMacroDefinition :: + (MonadError Error m) + => [AST.MacroDefinition] + -> Parse.Expression + -> m (Maybe AST.MacroDefinition) +lookupMacroDefinition environment identifierExpression = + case identifierExpression of + Parse.LiteralChar _ -> return Nothing + Parse.LiteralInt _ -> return Nothing + Parse.SExpression _ -> return Nothing + Parse.Symbol identifier -> + case filter + (\macroDefinition -> macroDefinition ^. name == identifier) + environment of + [] -> return Nothing + [macroDefinition] -> return $ Just macroDefinition + _ -> throwError (MacroError "0012") diff --git a/src/Lihsp/Normalize.hs b/src/Lihsp/Normalize.hs index a39bcd5..b57a771 100644 --- a/src/Lihsp/Normalize.hs +++ b/src/Lihsp/Normalize.hs @@ -5,12 +5,9 @@ module Lihsp.Normalize where -import Control.Lens.Operators ((%~), (^.)) import Control.Monad ((>=>)) import Control.Monad.Except (MonadError, throwError) -import Data.Function ((&)) - import Lihsp.AST ( ArgumentList(ArgumentList) , DataDeclaration(DataDeclaration) @@ -21,7 +18,7 @@ import Lihsp.AST , ImportList(ImportList) , LanguagePragma(LanguagePragma) , LetBlock(LetBlock) - , Literal(LChar, LInt, LList) + , Literal(LChar, LInt, LList, LSymbol) , MacroDefinition(MacroDefinition) , QualifiedImport(QualifiedImport) , RestrictedImport(RestrictedImport) @@ -32,23 +29,19 @@ import Lihsp.AST , TypeDefinition(ProperType, TypeConstructor) , TypeSynonym(TypeSynonym) , TypeclassInstance(TypeclassInstance) - , arguments - , function ) import Lihsp.Error (Error(NormalizeError)) import qualified Lihsp.Parse as Parse - ( Expression(LiteralChar, LiteralInt, LiteralList, SExpression, - Symbol) + ( Expression(LiteralChar, LiteralInt, SExpression, Symbol) ) normalizeExpression :: (MonadError Error m) => Parse.Expression -> m Expression normalizeExpression (Parse.LiteralChar char) = return $ ELiteral (LChar char) normalizeExpression (Parse.LiteralInt int) = return $ ELiteral (LInt int) -normalizeExpression (Parse.LiteralList list) = - ELiteral . LList <$> traverse normalizeExpression list normalizeExpression (Parse.SExpression items) = case items of + [Parse.Symbol "quote", expression] -> return $ toLihspLiteral expression [Parse.Symbol "let", Parse.SExpression bindings', body] -> let bindings = traverse @@ -154,14 +147,3 @@ normalizeStatement _ = throwError $ NormalizeError "0008" normalizeProgram :: (MonadError Error m) => [Parse.Expression] -> m [Statement] normalizeProgram = traverse normalizeStatement - -bottomUpTraverse :: (Applicative m) => (Expression -> m Expression) -> Expression -> m Expression -bottomUpTraverse f x = - case x of - EFunctionApplication functionApplication -> - f . EFunctionApplication <$> - (FunctionApplication <$> f (functionApplication ^. function) <*> - traverse f (functionApplication ^. arguments)) - EIdentifier _ -> f x - ELetBlock _ -> f x - ELiteral _ -> f x diff --git a/src/Lihsp/Parse.hs b/src/Lihsp/Parse.hs index 6dcf82a..d0025df 100644 --- a/src/Lihsp/Parse.hs +++ b/src/Lihsp/Parse.hs @@ -4,6 +4,7 @@ -- (due to the dependency on `BottomUp`). Fortunately, `Lihsp.Parse.AST` will (should) -- never be imported by itself but only implicitly as part of this module. {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -16,16 +17,17 @@ module Lihsp.Parse import Control.Monad.Except (MonadError, throwError) import Lihsp.Error (Error(ParseError)) + +-- Re-exporting these so that consumers of parsed ASTs do not need +-- to know about the internal file. import Lihsp.Parse.AST - (Expression(LiteralChar, LiteralInt, LiteralList, SExpression, - Symbol)) + ( Expression(LiteralChar, LiteralInt, SExpression, Symbol) + ) import Lihsp.Utils.Display (isOperator, kebabToCamelCase) -import Lihsp.Utils.Recursion - (Recursive(bottomUp)) +import Lihsp.Utils.Recursion (Recursive(bottomUp, bottomUpTraverse)) import Text.Parsec (ParsecT, Stream, (<|>), eof, parse, try) -import Text.Parsec.Char - (alphaNum, char, digit, letter, noneOf, oneOf, space) +import Text.Parsec.Char (alphaNum, char, digit, letter, noneOf, oneOf, space) import Text.Parsec.Combinator (many1, optional) import Text.Parsec.Prim (many) @@ -41,15 +43,10 @@ literalChar = LiteralChar <$> (char '\\' *> 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 = LiteralList <$> (char '[' *> many item <* char ']') - where - item = try (whitespace *> expression) <|> expression - literalString :: Stream s m Char => ParsecT s u m Expression -literalString = - LiteralList <$> - (map LiteralChar <$> (char '"' *> many (noneOf "\"") <* char '"')) +literalString = do + chars <- char '"' *> many (noneOf "\"") <* char '"' + pure $ SExpression [Symbol "quote", SExpression (map LiteralChar chars)] sExpression :: Stream s m Char => ParsecT s u m Expression sExpression = SExpression <$> (char '(' *> many item <* char ')') @@ -65,8 +62,7 @@ symbol = expression :: Stream s m Char => ParsecT s u m Expression expression = - literalChar <|> literalInt <|> literalList <|> literalString <|> sExpression <|> - symbol + literalChar <|> literalInt <|> literalString <|> sExpression <|> symbol program :: Stream s m Char => ParsecT s u m [Expression] program = @@ -80,15 +76,25 @@ normalizeCase (Symbol x) = else Symbol x normalizeCase x = x +-- 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?) instance Recursive Expression where bottomUp :: (Expression -> Expression) -> Expression -> Expression bottomUp f x = case x of LiteralChar _ -> f x LiteralInt _ -> f x - LiteralList xs -> f $ LiteralList (map (bottomUp f) xs) SExpression xs -> f $ SExpression (map (bottomUp f) xs) Symbol _ -> f x + bottomUpTraverse :: + (Monad m) => (Expression -> m Expression) -> Expression -> m Expression + bottomUpTraverse f x = + case x of + LiteralChar _ -> f x + LiteralInt _ -> f x + SExpression xs -> f =<< (SExpression <$> traverse (bottomUpTraverse f) xs) + Symbol _ -> f x parseProgram :: (MonadError Error m) => String -> m [Expression] parseProgram = diff --git a/src/Lihsp/Parse/AST.hs b/src/Lihsp/Parse/AST.hs index 8cfec56..b20852a 100644 --- a/src/Lihsp/Parse/AST.hs +++ b/src/Lihsp/Parse/AST.hs @@ -9,7 +9,6 @@ import Data.Semigroup ((<>)) data Expression = LiteralChar Char | LiteralInt Int - | LiteralList [Expression] | SExpression [Expression] | Symbol String @@ -17,6 +16,18 @@ instance Show Expression where show :: Expression -> String show (LiteralChar x) = ['\'', x, '\''] show (LiteralInt x) = show x - show (LiteralList xs) = "[" <> unwords (map show xs) <> "]" show (SExpression xs) = "(" <> unwords (map show xs) <> ")" show (Symbol x) = x + +-- 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?) +traverseExpression :: + (Monad m) => (Expression -> m Expression) -> Expression -> m Expression +traverseExpression f expression = + case expression of + LiteralChar _ -> f expression + LiteralInt _ -> f expression + SExpression expressions -> + f =<< (SExpression <$> traverse (traverseExpression f) expressions) + Symbol _ -> f expression diff --git a/src/Lihsp/Utils/Recursion.hs b/src/Lihsp/Utils/Recursion.hs index ba03b1e..f9bbf8c 100644 --- a/src/Lihsp/Utils/Recursion.hs +++ b/src/Lihsp/Utils/Recursion.hs @@ -3,3 +3,6 @@ module Lihsp.Utils.Recursion where -- TODO Use `Fix`-based recursion schemes instead. class Recursive a where bottomUp :: (a -> a) -> a -> a + -- TODO Remove dependency on `Monad` in favor of `Applicative` + -- (which is all the standard `traverse` requires). + bottomUpTraverse :: (Monad m) => (a -> m a) -> a -> m a diff --git a/src/Lihsp/Utils/String.hs b/src/Lihsp/Utils/String.hs new file mode 100644 index 0000000..c8bf40d --- /dev/null +++ b/src/Lihsp/Utils/String.hs @@ -0,0 +1,7 @@ +module Lihsp.Utils.String where + +import qualified Data.Text as T (pack, replace, unpack) + +replace :: String -> String -> String -> String +replace needle replacement haystack = + T.unpack $ T.replace (T.pack needle) (T.pack replacement) (T.pack haystack)