Continue macro expansion

Author: Joshua Grosso

lihsp.cabal

@@ -1,6 +1,8 @@
--- This file has been generated from package.yaml by hpack version 0.17.0.
+-- This file has been generated from package.yaml by hpack version 0.20.0.
 --
 -- see: https://github.com/sol/hpack
+--
+-- hash: 596fc166e921fb1d089e6c0008a31999fb69a79ec742eb8f8582f5c30b048f6a
 
 name:           lihsp
 version:        0.1.0.0
@@ -40,15 +42,21 @@ library
     , parsec
     , process
     , split
+    , text
   exposed-modules:
       Lihsp.AST
       Lihsp.Error
+      Lihsp.Eval
       Lihsp.Macros
       Lihsp.Normalize
       Lihsp.Parse
       Lihsp.Parse.AST
       Lihsp.Transpile
-      Lihsp.Utils
+      Lihsp.Utils.Display
+      Lihsp.Utils.Recursion
+      Lihsp.Utils.Resources
+  other-modules:
+      Paths_lihsp
   default-language: Haskell2010
 
 executable lihsp-exe
@@ -59,16 +67,19 @@ executable lihsp-exe
   build-depends:
       base >=4.7 && <5
     , lihsp
+  other-modules:
+      Paths_lihsp
   default-language: Haskell2010
 
 test-suite lihsp-test
   type: exitcode-stdio-1.0
-  main-is: Spec.hs
+  main-is: Lihsp/Spec.hs
   hs-source-dirs:
       test
   ghc-options: -Wall -Werror -Wmissing-import-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
+    , hspec
   other-modules:
-      Lihsp.Spec
+      Paths_lihsp
   default-language: Haskell2010

package.yaml

@@ -29,6 +29,7 @@ library:
   - parsec
   - process
   - split
+  - text
 executables:
   lihsp-exe:
     main: Main.hs
@@ -41,9 +42,11 @@ executables:
     - lihsp
 tests:
   lihsp-test:
-    main: Spec.hs
+    main: Lihsp/Spec.hs
     source-dirs: test
     ghc-options:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    dependencies:
+    - hspec

resources/macros/Footer.hs

@@ -1,2 +1,4 @@
+%%%MACRO_DEFINITION%%%
+
 main :: IO ()
-main = getArgs >>= aUTOGENERATED_MACRO_FUNCTION >>= print
+main = aUTOGENERATED_MACRO_FUNCTION %%%%ARGUMENTS%%% >>= print

src/Lihsp/AST.hs

@@ -13,10 +13,15 @@ import Control.Lens.TH (makeFieldsNoPrefix)
 
 import Data.Semigroup ((<>))
 
-import Lihsp.Utils
-       (Bracket(Parentheses, SingleQuotes, SquareBrackets),
-        Delimiter(Commas, Newlines, Pipes, Spaces), delimit, isOperator,
-        renderBlock, renderPragma, surround)
+import Lihsp.Utils.Display
+  ( Bracket(Parentheses, SingleQuotes, SquareBrackets)
+  , Delimiter(Commas, Newlines, Pipes, Spaces)
+  , delimit
+  , isOperator
+  , renderBlock
+  , renderPragma
+  , surround
+  )
 
 type Identifier = String
 
@@ -262,3 +267,23 @@ 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

src/Lihsp/Eval.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Lihsp.Eval where
+
+import Control.Monad.Except (MonadError, throwError)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+
+import Lihsp.Error (Error(MacroError))
+
+import System.Directory (getTemporaryDirectory, removeFile)
+import System.Exit (ExitCode(ExitFailure, ExitSuccess))
+import System.IO (Handle, hClose, hPutStr, openTempFile)
+import System.Process (readProcessWithExitCode)
+
+withTempFile :: (MonadIO m) => FilePath -> (FilePath -> Handle -> m a) -> m a
+withTempFile nameTemplate f = do
+  temporaryDirectory <- liftIO getTemporaryDirectory
+  (fileName, handle) <- liftIO $ openTempFile temporaryDirectory nameTemplate
+  result <- f fileName handle
+  liftIO $ hClose handle
+  liftIO $ removeFile fileName
+  return result
+
+execInterpreter :: (MonadError Error m, MonadIO m) => FilePath -> m String
+execInterpreter fileName = do
+  (code, stdout, stderr) <-
+    liftIO $ readProcessWithExitCode "runhaskell" [fileName] ""
+  case code of
+    ExitSuccess -> return stdout
+    ExitFailure _ -> throwError $ MacroError stderr
+
+evalSource :: (MonadError Error m, MonadIO m) => String -> m String
+evalSource source =
+  withTempFile "TempMaro.hs" $ \fileName handle -> do
+    liftIO $ hPutStr handle source
+    execInterpreter fileName

src/Lihsp/Macros.hs

@@ -1,70 +1,57 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
 
-{-
-The below module is most definitely a Work In Progress. Yay!
-
-Macros edit the parse tree, which the compiler converts to an AST which is transpiled into Eta.
-1. When macros are expanded, the code forms passed in as its arguments are represented as a list of parse expressions (lists, symbols, literals, etc.).
-   The output of the macro programs is rendered as a list and inserted back into the file.
-2. Step 1 is repeated until no more macros are available for expansion.
-3. The whole file is then tranpsiled into Eta as usual.
-
-MACRO EXPANSION STRATEGY
-This is just a very, very rough hypothesis. It's probably broken, and I have no idea how it would be adapted to work with macros defined in multiple files or mutually-recursive macros (or even self-recursive macros). You have been warned.
-I'm assuming macros should be expanded inner-to-outer (since Lisps let allow for using macros inside macros, e.g. `with-gensyms` and its ilk).
-1. Read the file top-to-bottom, collecting macro definitions.
-   For each macro definition, check if already-defined macros are being used inside the definition. If so, expand their usages and repeat until there are no macro usages left in each definition.
-2. Expand the deepest macro usages inside each non-`defmacro` expression. Repeat until there are no macro usages left.
--}
 module Lihsp.Macros where
 
-import Control.Lens.Operators ((&), (.~))
-import Control.Monad.Except (MonadError, throwError)
+import Control.Lens.Operators ((.~))
+import Control.Monad.Except (MonadError)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 
+import Data.Function ((&))
 import Data.Semigroup ((<>))
+import Data.Text (pack, replace, unpack)
 
-import Lihsp.AST (MacroDefinition, name)
+import Lihsp.AST (Expression, MacroDefinition, name, traverseExpression)
 import Lihsp.Error (Error(MacroError))
+import Lihsp.Eval (evalSource)
 import qualified Lihsp.Parse as Parse (Expression)
 import Lihsp.Parse (parseProgram)
-
-import Paths_lihsp (getDataFileName)
-
-import System.Directory (getTemporaryDirectory, removeFile)
-import System.Exit (ExitCode(ExitFailure, ExitSuccess))
-import System.IO (Handle, hClose, hPutStr, openTempFile)
-import System.Process (readProcessWithExitCode)
-
-withTempFile :: (MonadIO m) => FilePath -> (FilePath -> Handle -> m a) -> m a
-withTempFile template f = do
-  temporaryDirectory <- liftIO getTemporaryDirectory
-  (fileName, handle) <- liftIO $ openTempFile temporaryDirectory template
-  result <- f fileName handle
-  liftIO $ hClose handle
-  liftIO $ removeFile fileName
-  return result
-
-generateMacroProgram :: MacroDefinition -> IO String
-generateMacroProgram macroDefinition = do
-  let macroSource = macroDefinition & name .~ "aUTOGENERATED_MACRO_FUNCTION"
-  footer <- getDataFileName "resources/macros/Footer.hs" >>= readFile
-  header <- getDataFileName "resources/macros/Header.hs" >>= readFile
-  return $ header <> show macroSource <> footer
-
-execInterpreter :: (MonadError Error m, MonadIO m) => FilePath -> m String
-execInterpreter fileName = do
-  (code, stdout, stderr) <-
-    liftIO $ readProcessWithExitCode "runhaskell" [fileName] ""
-  case code of
-    ExitSuccess -> return stdout
-    ExitFailure _ -> throwError $ MacroError stderr
-
-runMacro ::
-     (MonadError Error m, MonadIO m) => MacroDefinition -> m [Parse.Expression]
-runMacro macroSource =
-  withTempFile "TempMacro.hs" $ \fileName handle -> do
-    macroProgram <- liftIO $ generateMacroProgram macroSource
-    liftIO $ hPutStr handle macroProgram
-    result <- execInterpreter fileName
-    parseProgram result
+import Lihsp.Utils.Resources (readDataFile)
+
+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
+  where
+    getFileFooter =
+      let insertApplicationArguments =
+            let applicationArgumentsPlaceholder = "%%%ARGUMENTS%%%"
+            in unpack .
+               replace
+                 applicationArgumentsPlaceholder
+                 (pack $ show applicationArguments) .
+               pack
+          insertDefinitionBody =
+            let definitionBodyPlaceholder = "%%%MACRO_DEFINITION%%%"
+            in unpack .
+               replace definitionBodyPlaceholder (pack $ show macroDefinition) .
+               pack
+      in insertApplicationArguments . insertDefinitionBody <$>
+         readDataFile "resources/macros/Footer.hs"
+
+expandMacroCall ::
+     (MonadError Error m, MonadIO m)
+  => MacroDefinition
+  -> [Expression]
+  -> m [Parse.Expression]
+expandMacroCall macroDefinition args =
+  generateMacroProgram macroDefinition args >>= evalSource >>= parseProgram
+
+expandMacros :: Expression -> IO Expression
+expandMacros =
+  traverseExpression $ \expression ->
+    case macroApplication expression of
+      Just (macroName, arguments) -> expandMacroCall
+      Nothing -> return expression

src/Lihsp/Normalize.hs

@@ -1,33 +1,46 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TupleSections #-}
 
 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),
-        Expression(EFunctionApplication, EIdentifier, ELetBlock, ELiteral),
-        FunctionApplication(FunctionApplication),
-        FunctionDefinition(FunctionDefinition),
-        Import(ImportItem, ImportType), ImportList(ImportList),
-        LanguagePragma(LanguagePragma), LetBlock(LetBlock),
-        Literal(LChar, LInt, LList), MacroDefinition(MacroDefinition),
-        QualifiedImport(QualifiedImport),
-        RestrictedImport(RestrictedImport),
-        Statement(SDataDeclaration, SFunctionDefinition, SLanguagePragma,
-                  SMacroDefinition, SModuleDeclaration, SQualifiedImport,
-                  SRestrictedImport, STypeSynonym, STypeclassInstance,
-                  SUnrestrictedImport),
-        TypeDefinition(ProperType, TypeConstructor),
-        TypeSynonym(TypeSynonym), TypeclassInstance(TypeclassInstance))
+  ( ArgumentList(ArgumentList)
+  , DataDeclaration(DataDeclaration)
+  , Expression(EFunctionApplication, EIdentifier, ELetBlock, ELiteral)
+  , FunctionApplication(FunctionApplication)
+  , FunctionDefinition(FunctionDefinition)
+  , Import(ImportItem, ImportType)
+  , ImportList(ImportList)
+  , LanguagePragma(LanguagePragma)
+  , LetBlock(LetBlock)
+  , Literal(LChar, LInt, LList)
+  , MacroDefinition(MacroDefinition)
+  , QualifiedImport(QualifiedImport)
+  , RestrictedImport(RestrictedImport)
+  , Statement(SDataDeclaration, SFunctionDefinition, SLanguagePragma,
+          SMacroDefinition, SModuleDeclaration, SQualifiedImport,
+          SRestrictedImport, STypeSynonym, STypeclassInstance,
+          SUnrestrictedImport)
+  , 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, LiteralList, SExpression,
+           Symbol)
+  )
 
 normalizeExpression :: (MonadError Error m) => Parse.Expression -> m Expression
 normalizeExpression (Parse.LiteralChar char) = return $ ELiteral (LChar char)
@@ -141,3 +154,14 @@ 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