Finish macro expansion!

.gitignore

@@ -23,6 +23,7 @@ cabal.project.local
 
 .DS_Store
 
+axelTemp
 resources/autogenerated/*
 
 ctags

.hindent.yaml

@@ -0,0 +1 @@
+force-trailing-newline: true

examples/example.axel

@@ -1,30 +1,30 @@
 -- This is just an example, and, since it's partial, is NOT advised for actual use.
 (defmacro' when
- (([condition body]) (pure [`(if ,condition ,body (error "WHEN"))])))
+  (([condition body]) (pure [`(if ~condition ~body (error "WHEN"))])))
 
 (defmacro defmacro'
- ((exprs)
-   (pure [`(defmacro ,@exprs)])))
+  ((exprs)
+   (pure [`(defmacro ~@exprs)])))
 
 (defmacro if
- (([cond true false])
-  (pure [`(case ,cond
-            (True ,true)
-            (False ,false))])))
+  (([cond true false])
+   (pure [`(case ~cond
+             (True ~true)
+             (False ~false))])))
 
 (defmacro quasiquote
- (([(SExpression xs)])
-  (let ((quasiquoteElem (fn (x) (case x
-                                 ((SExpression ['unquote x])
-                                  (SExpression ['list x]))
-                                 ((SExpression ['unquote-splicing x])
-                                  x)
-                                 (atom
-                                  (SExpression
-                                   ['list
-                                    (SExpression ['quasiquote atom])]))))))
-   (pure [(SExpression ['SExpression (SExpression ['concat (SExpression (: 'list (map quasiquoteElem xs)))])])])))
- (([atom]) (pure [(SExpression (list 'quote atom))])))
+  (([(AST.SExpression xs)])
+   (let ((quasiquoteElem (fn (x) (case x
+                                   ((AST.SExpression ['unquote x])
+                                    (AST.SExpression ['list x]))
+                                   ((AST.SExpression ['unquoteSplicing x])
+                                    x)
+                                   (atom
+                                    (AST.SExpression
+                                     ['list
+                                      (AST.SExpression ['quasiquote atom])]))))))
+     (pure [(AST.SExpression ['AST.SExpression (AST.SExpression ['concat (AST.SExpression (: 'list (map quasiquoteElem xs)))])])])))
+  (([atom]) (pure [(AST.SExpression ['quote atom])])))
 
 (= main (IO Unit)
- (() (when (== 1 1) (putStrLn "Hi!"))))
+   (() (if (== 1 1) (putStrLn "Hi!") (putStrLn "wat"))))

package.yaml

@@ -16,22 +16,28 @@ ghc-options:
 - -Wincomplete-record-updates
 - -Wincomplete-uni-patterns
 dependencies:
-- base >=4.7 && <5
+- base >=4.11.1 && <4.12
 data-files:
 - resources/**/*
 library:
   source-dirs: src
   exposed-modules:
   - Axel.Entry
   dependencies:
-  - directory
-  - filepath
-  - lens
-  - mtl
-  - parsec
-  - process
-  - split
-  - text
+  - aeson >=1.3.1 && <1.4
+  - bytestring >=0.10.8 && <0.11
+  - directory >=1.3 && <1.4
+  - filepath >=1.4.1 && <1.5
+  - ghc ==8.4.3
+  - haskell-src-exts >=1.20.2 && <1.21
+  - lens >=4.16.1 && <4.17
+  - monad-control >=1.0.2 && <1.1
+  - mtl >=2.2.1 && <2.3
+  - parsec >=3.1.11 && <3.2
+  - process >=1.6.1 && <1.7
+  - split >=0.2.3 && <0.3
+  - strict >=0.3.2 && <0.4
+  - text >=1.2.2 && <1.3
 executables:
   axel-exe:
     main: Main.hs

resources/macros/MacroDefinitionAndEnvironmentHeader.hs

@@ -0,0 +1,3 @@
+module MacroDefinitionAndEnvironment where
+
+import qualified Axel.Parse.AST as AST

resources/macros/Scaffold.hs

@@ -0,0 +1,10 @@
+module Scaffold where
+
+import Axel.Parse.AST
+import qualified MacroDefinitionAndEnvironment as MacroDefinitionAndEnvironment
+
+main :: IO ()
+main = do
+  result <-
+    MacroDefinitionAndEnvironment.%%%MACRO_NAME%%% %%%ARGUMENTS%%%
+  putStrLn $ unlines $ map toAxel result

scripts/build.sh

@@ -3,7 +3,7 @@ set -o pipefail
 
 echo "Copying macro header..."
 mkdir -p resources/autogenerated/macros
-cp src/Axel/Parse/AST.hs resources/autogenerated/macros/Header.hs
+cp src/Axel/Parse/AST.hs resources/autogenerated/macros/AST.hs
 echo "Macro header copied!"
 
 stack build

src/Axel/AST.hs

@@ -9,6 +9,7 @@
 
 module Axel.AST where
 
+import Axel.Error (fatal)
 import Axel.Utils.Display
   ( Bracket(DoubleQuotes, Parentheses, SingleQuotes, SquareBrackets)
   , Delimiter(Commas, Newlines, Pipes, Spaces)
@@ -18,10 +19,13 @@ import Axel.Utils.Display
   , renderPragma
   , surround
   )
+import Axel.Utils.Recursion (Recursive(bottomUpFmap, bottomUpTraverse))
 
-import Control.Lens.Operators ((^.))
+import Control.Lens.Operators ((^.), (%~))
 import Control.Lens.TH (makeFieldsNoPrefix)
+import Control.Lens.Tuple (_1, _2)
 
+import Data.Function ((&))
 import Data.Semigroup ((<>))
 
 class ToHaskell a where
@@ -106,7 +110,7 @@ newtype LanguagePragma = LanguagePragma
   } deriving (Eq)
 
 data LetBlock = LetBlock
-  { _bindings :: [(Identifier, Expression)]
+  { _bindings :: [(Expression, Expression)]
   , _body :: Expression
   } deriving (Eq)
 
@@ -297,14 +301,14 @@ instance ToHaskell LetBlock where
     " in " <>
     toHaskell (letBlock ^. body)
     where
-      bindingToHaskell (identifier, value) =
-        identifier <> " = " <> toHaskell value
+      bindingToHaskell (pattern', value) =
+        toHaskell pattern' <> " = " <> toHaskell value
 
 instance ToHaskell MacroDefinition where
   toHaskell :: MacroDefinition -> String
   toHaskell macroDefinition =
     delimit Newlines $
-    (macroDefinition ^. name <> " :: [Expression] -> IO [Expression]") :
+    (macroDefinition ^. name <> " :: [AST.Expression] -> IO [AST.Expression]") :
     map
       (functionDefinitionToHaskell $ macroDefinition ^. name)
       (macroDefinition ^. definitions)
@@ -337,3 +341,105 @@ instance ToHaskell TypeSynonym where
   toHaskell typeSynonym =
     "type " <> toHaskell (typeSynonym ^. alias) <> " = " <>
     toHaskell (typeSynonym ^. definition)
+
+instance Recursive Expression where
+  bottomUpFmap :: (Expression -> Expression) -> Expression -> Expression
+  bottomUpFmap f x =
+    f $
+    case x of
+      ECaseBlock caseBlock ->
+        ECaseBlock $
+        caseBlock &
+          expr %~ bottomUpFmap f &
+          matches %~ map (\(a, b) -> (bottomUpFmap f a, bottomUpFmap f b))
+      EEmptySExpression -> f x
+      EFunctionApplication functionApplication ->
+        EFunctionApplication $
+        functionApplication &
+          function %~ bottomUpFmap f &
+          arguments %~ map (bottomUpFmap f)
+      EIdentifier _ -> x
+      ELambda lambda ->
+        ELambda $
+        lambda &
+          arguments %~ map (bottomUpFmap f) &
+          body %~ bottomUpFmap f
+      ELetBlock letBlock ->
+        ELetBlock $
+        letBlock &
+          bindings %~ map ((_1 %~ bottomUpFmap f) . (_2 %~ bottomUpFmap f)) &
+          body %~ bottomUpFmap f
+      ELiteral literal ->
+        case literal of
+          LChar _ -> x
+          LInt _ -> x
+          LList exprs -> ELiteral (LList $ map (bottomUpFmap f) exprs)
+          LString _ -> x
+  bottomUpTraverse :: (Monad m) => (Expression -> m Expression) -> Expression -> m Expression
+  bottomUpTraverse f x =
+    f =<<
+    case x of
+      ECaseBlock caseBlock ->
+        ECaseBlock <$>
+        (CaseBlock <$>
+        bottomUpTraverse f (caseBlock ^. expr) <*>
+        traverse (\(a, b) -> (,) <$> bottomUpTraverse f a <*> bottomUpTraverse f b) (caseBlock ^. matches))
+      EEmptySExpression -> pure x
+      EFunctionApplication functionApplication ->
+        EFunctionApplication <$>
+        (FunctionApplication <$>
+        bottomUpTraverse f (functionApplication ^. function) <*>
+        traverse (bottomUpTraverse f) (functionApplication ^. arguments))
+      EIdentifier _ -> pure x
+      ELambda lambda ->
+        ELambda <$>
+        (Lambda <$>
+        traverse (bottomUpTraverse f) (lambda ^. arguments) <*>
+        bottomUpTraverse f (lambda ^. body))
+      ELetBlock letBlock ->
+        ELetBlock <$>
+        (LetBlock <$>
+        traverse (\(a, b) -> (a,) <$> bottomUpTraverse f b) (letBlock ^. bindings) <*>
+        bottomUpTraverse f (letBlock ^. body))
+      ELiteral literal ->
+        case literal of
+          LChar _ -> pure x
+          LInt _ -> pure x
+          LList exprs -> ELiteral . LList <$> traverse (bottomUpTraverse f) exprs
+          LString _ -> pure x
+
+extractNameFromDefinition :: Statement -> Maybe Identifier
+extractNameFromDefinition (SDataDeclaration dataDeclaration) =
+  Just $
+  case dataDeclaration ^. typeDefinition of
+    ProperType typeName -> typeName
+    TypeConstructor fnApp ->
+      case fnApp ^. function of
+        ELiteral (LString typeName) -> typeName
+        _ -> fatal "extractNameFromDefinition" "0001"
+extractNameFromDefinition (SFunctionDefinition functionDefinition) =
+  Just $ functionDefinition ^. name
+extractNameFromDefinition (SLanguagePragma _) = Nothing
+extractNameFromDefinition (SMacroDefinition _) = Nothing
+extractNameFromDefinition (SModuleDeclaration _) = Nothing
+extractNameFromDefinition (SQualifiedImport _) = Nothing
+extractNameFromDefinition (SRestrictedImport _) = Nothing
+extractNameFromDefinition (STopLevel _) = Nothing
+extractNameFromDefinition (STypeclassInstance typeclassInstance) =
+  case typeclassInstance ^. instanceName of
+    ELiteral (LString identifier) -> Just identifier
+    _ -> Nothing
+extractNameFromDefinition (STypeSynonym typeSynonym) =
+  case typeSynonym ^. alias of
+    ELiteral (LString identifier) -> Just identifier
+    _ -> Nothing
+extractNameFromDefinition (SUnrestrictedImport _) = Nothing
+
+removeDefinitionsByName :: [String] -> [Statement] -> [Statement]
+removeDefinitionsByName namesToRemove =
+  filter
+    (\statement ->
+       not $
+       case extractNameFromDefinition statement of
+         Just definitionName -> definitionName `elem` namesToRemove
+         Nothing -> False)