WIP

Author: jgrosso

axel.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 72e1c0a2ad6eab54ed0144120fbe5cb23511fea32286f226574a144ccf14631f
+-- hash: 8d0ab6a7586d20892da1b6d2e8108404859096bc5719a7f3a8e30ebb8d4c4cf1
 
 name:           axel
 version:        0.1.0.0
@@ -20,6 +20,7 @@ extra-source-files:
     README.org
     scripts/build.sh
     scripts/clean.sh
+    scripts/lint.sh
 data-files:
     resources/autogenerated/macros/AST.hs
     resources/macros/MacroDefinitionAndEnvironmentHeader.hs

examples/do/app/Main.axel

@@ -1,10 +1,10 @@
 (module Main)
 
 (defmacro fnCase
-    ((cases) (<$> (fn (varId)
-                      [`(fn (~varId)
-                            (case ~varId ~@cases))])
-                  AST.gensym)))
+  ((cases) (<$> (fn (varId)
+                  [`(fn (~varId)
+                      (case ~varId ~@cases))])
+                AST.gensym)))
 
 (defmacro quasiquote
   (([(AST.SExpression xs)])
@@ -20,18 +20,20 @@
      (pure [(AST.SExpression ['AST.SExpression (AST.SExpression ['concat (AST.SExpression (: 'list (map quasiquoteElem xs)))])])])))
   (([atom]) (pure [(AST.SExpression ['quote atom])])))
 
+(= do' (-> ([] AST.Expression) AST.Expression)
+   (() (fnCase
+        ((: var (: '<- (: val rest)))
+         `(>>= ~val (fn (~var) ~(do' rest))))
+        ((: val rest)
+         (case rest
+           ([]
+            val)
+           (_
+            `(>> ~val ~(do' rest))))))))
+
 (defmacro do
   ((input)
-   (let ((go (fnCase
-              ((: var (: '<- (: val rest)))
-               `(>>= ~val (fn (~var) ~(go rest))))
-              ((: val rest)
-               (case rest
-                ([]
-                 val)
-                (_
-                 `(>> ~val ~(go rest))))))))
-     (pure [(go input)]))))
+   (pure [(do' input)])))
 
 (= main (IO Unit)
    (() (do

src/Axel/AST.hs

@@ -21,6 +21,7 @@ import Axel.Utils.Display
   )
 import Axel.Utils.Recursion (Recursive(bottomUpFmap, bottomUpTraverse))
 
+import Control.Arrow ((***))
 import Control.Lens.Operators ((%~), (^.))
 import Control.Lens.TH (makeFieldsNoPrefix)
 import Control.Lens.Tuple (_1, _2)
@@ -350,7 +351,7 @@ instance Recursive Expression where
       ECaseBlock caseBlock ->
         ECaseBlock $
         caseBlock & expr %~ bottomUpFmap f & matches %~
-        map (\(a, b) -> (bottomUpFmap f a, bottomUpFmap f b))
+        map (bottomUpFmap f *** bottomUpFmap f)
       EEmptySExpression -> f x
       EFunctionApplication functionApplication ->
         EFunctionApplication $

src/Axel/Eval.hs

@@ -18,7 +18,7 @@ execInterpreter ::
      (MonadError Error m, MonadIO m)
   => FilePath
   -> FilePath
-  -> m (Either [String] String)
+  -> m (Either (String, [String]) String)
 execInterpreter scaffoldFilePath macroDefinitionAndEnvironmentFilePath = do
   debugResult <- liftIO $ buildWithGHC scaffoldFilePath
   case debugResult of
@@ -31,14 +31,14 @@ execInterpreter scaffoldFilePath macroDefinitionAndEnvironmentFilePath = do
           jsonLog
       case invalidDefinitionNames of
         [] -> throwError $ MacroError stderr
-        _ -> pure $ Left invalidDefinitionNames
+        _ -> pure $ Left (stderr, invalidDefinitionNames)
 
 evalMacro ::
      (MonadBaseControl IO m, MonadError Error m, MonadIO m)
   => String
   -> String
   -> String
-  -> m (Either [String] String)
+  -> m (Either (String, [String]) String)
 evalMacro astDefinition scaffold macroDefinitionAndEnvironment =
   withTempDirectory $ \directoryName ->
     withCurrentDirectoryLifted directoryName $ do

src/Axel/Macros.hs

@@ -17,7 +17,7 @@ import Axel.AST
   , statements
   )
 import Axel.Denormalize (denormalizeExpression, denormalizeStatement)
-import Axel.Error (Error(MacroError), fatal)
+import Axel.Error (Error(MacroError))
 import Axel.Eval (evalMacro)
 import Axel.Normalize (normalizeStatement)
 import qualified Axel.Parse as Parse
@@ -35,16 +35,17 @@ import Axel.Utils.Resources (readDataFile)
 import Axel.Utils.String (replace)
 
 import Control.Lens.Operators ((%~), (^.))
-import Control.Lens.Tuple (_1, _2)
 import Control.Monad (foldM)
 import Control.Monad.Except (MonadError, catchError, throwError)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Trans.Control (MonadBaseControl)
 
-import Data.Function ((&))
-import Data.List (foldl')
+import Data.List (foldl', partition)
+import Data.Maybe (listToMaybe)
 import Data.Semigroup ((<>))
 
+import Debug.Trace (trace)
+
 getAstDefinition :: IO String
 getAstDefinition = readDataFile "autogenerated/macros/AST.hs"
 
@@ -120,15 +121,17 @@ expansionPass programExpr = do
         extractIndependentStatements $ programToStmts programExpr
   normalizedStmts <- traverse normalizeStatement independentStmts
   let nonconflictingStmts = filter canInclude normalizedStmts
-  let (macroDefs, auxEnv) =
-        foldl
-          (\acc x ->
-             case x of
-               SMacroDefinition macroDef -> acc & _1 %~ (macroDef :)
-               _ -> acc & _2 %~ (<> [x]))
-          ([], [])
-          nonconflictingStmts
-  expandMacros macroDefs auxEnv programExpr
+  let maybeFirstMacroDef =
+        listToMaybe $ filter isMacroDefinitionStatement nonconflictingStmts
+  case maybeFirstMacroDef of
+    Just (SMacroDefinition firstMacroDef) ->
+      let otherStmts =
+            filter (/= SMacroDefinition firstMacroDef) nonconflictingStmts
+      in expandMacro
+           (trace (toHaskell $ SMacroDefinition firstMacroDef) firstMacroDef)
+           otherStmts
+           programExpr
+    _ -> pure programExpr
   where
     canInclude :: Statement -> Bool
     canInclude =
@@ -156,13 +159,13 @@ exhaustivelyExpandMacros ::
 exhaustivelyExpandMacros = exhaustM expansionPass
 
 -- TODO This needs heavy optimization.
-expandMacros ::
+expandMacro ::
      (MonadBaseControl IO m, MonadError Error m, MonadIO m)
-  => [MacroDefinition]
+  => MacroDefinition
   -> [Statement]
   -> Parse.Expression
   -> m Parse.Expression
-expandMacros macroDefs auxEnv =
+expandMacro macroDef auxEnv =
   bottomUpTraverse $ \expr ->
     case expr of
       Parse.LiteralChar _ -> pure expr
@@ -178,11 +181,9 @@ expandMacros macroDefs auxEnv =
                Parse.LiteralString _ -> pure $ acc ++ [x]
                Parse.SExpression [] -> pure $ acc ++ [x]
                Parse.SExpression (function:args) ->
-                 lookupMacroDefinition macroDefs function >>= \case
-                   Just macroDefinition ->
-                     (acc ++) <$>
-                     expandMacroApplication macroDefinition auxEnv args
-                   Nothing -> pure $ acc ++ [x]
+                 if isMacroBeingCalled macroDef function
+                   then (acc ++) <$> expandMacroApplication macroDef auxEnv args
+                   else pure $ acc ++ [x]
                Parse.Symbol _ -> pure $ acc ++ [x])
           []
           xs
@@ -195,41 +196,31 @@ expandMacroApplication ::
   -> [Parse.Expression]
   -> m [Parse.Expression]
 expandMacroApplication macroDef rawAuxEnv args = do
-  auxEnv <- exhaustM pruneEnv rawAuxEnv
+  auxEnv <-
+    exhaustM pruneEnv $ filter (not . isMacroDefinitionStatement) rawAuxEnv
   result <- runMacro auxEnv
   case result of
     Right x -> Parse.parseMultiple x
-    Left _ -> fatal "expandMacroApplication" "0001"
+    Left (stderr, _) -> throwError $ MacroError stderr
   where
     pruneEnv auxEnv = do
       result <- runMacro auxEnv
       pure $
         case result of
           Right _ -> auxEnv
-          Left invalidDefs -> removeDefinitionsByName invalidDefs auxEnv
+          Left (_, invalidDefs) -> removeDefinitionsByName invalidDefs auxEnv
     runMacro auxEnv = do
       macroProgram <- generateMacroProgram macroDef auxEnv args
       uncurry3 evalMacro macroProgram
 
-lookupMacroDefinition ::
-     (MonadError Error m)
-  => [MacroDefinition]
-  -> Parse.Expression
-  -> m (Maybe MacroDefinition)
-lookupMacroDefinition macroDefs identifierExpr =
+isMacroBeingCalled :: MacroDefinition -> Parse.Expression -> Bool
+isMacroBeingCalled macroDef identifierExpr =
   case identifierExpr of
-    Parse.LiteralChar _ -> pure Nothing
-    Parse.LiteralInt _ -> pure Nothing
-    Parse.LiteralString _ -> pure Nothing
-    Parse.SExpression _ -> pure Nothing
-    Parse.Symbol identifier ->
-      case filter (\macroDef -> macroDef ^. name == identifier) macroDefs of
-        [] -> pure Nothing
-        [macroDef] -> pure $ Just macroDef
-        _ ->
-          throwError
-            (MacroError $
-             "Multiple macro definitions named: `" <> identifier <> "`!")
+    Parse.LiteralChar _ -> False
+    Parse.LiteralInt _ -> False
+    Parse.LiteralString _ -> False
+    Parse.SExpression _ -> False
+    Parse.Symbol identifier -> macroDef ^. name == identifier
 
 -- TODO This probably needs heavy optimization. If so, I will need to decrease the running time.
 extractMacroDefinitions :: Statement -> [MacroDefinition]
@@ -266,11 +257,13 @@ stripMacroDefinitions :: Statement -> Statement
 stripMacroDefinitions =
   \case
     STopLevel topLevel ->
-      STopLevel $ (statements %~ filter (not . isMacroDefinition)) topLevel
+      STopLevel $
+      (statements %~ filter (not . isMacroDefinitionStatement)) topLevel
     x -> x
-  where
-    isMacroDefinition (SMacroDefinition _) = True
-    isMacroDefinition _ = False
+
+isMacroDefinitionStatement :: Statement -> Bool
+isMacroDefinitionStatement (SMacroDefinition _) = True
+isMacroDefinitionStatement _ = False
 
 replaceName ::
      (MonadError Error m)