Streamline Bowtie.Interpret.

bowtie-js/src/Bowtie/JS.hs

@@ -48,7 +48,7 @@ function $compareBuiltin(a, b) {
 
 transpile :: Text -> Either Interpret.IError Text
 transpile src = do
-  (env, coreExpr) <- Interpret.sourceToCore src
+  (env, coreExpr) <- Interpret.sourcesToCore mempty ("<input>", src)
   pure (transpileCore env coreExpr)
 
 transpileCore :: Environment -> Expr -> Text

bowtie-visualize/src/Bowtie/Visualize.hs

@@ -38,7 +38,7 @@ run libFiles appFile = do
 
         dsg :: Surface.Expr
         dsg =
-          Surface.Desugar.desugarResult (astTerms ast)
+          Surface.Desugar.extractResult (astTerms ast)
 
       let
         f :: (MonadState Int m, MonadError TypeError m) => m [Constraints]

bowtie/src/Bowtie/Infer/BottomUp.hs

@@ -83,7 +83,7 @@ bottomUpLet env ms bindings expr = do
   let
     bindingList :: [(Id, (Expr, Type))]
     bindingList =
-      List.reverse (Desugar.desugarLet' bindings)
+      List.reverse (Desugar.flattenLetBindings bindings)
 
   (aBody, cBody, tBody) <- bottomUp env ms expr
 

bowtie/src/Bowtie/Interpret.hs

@@ -8,12 +8,12 @@ import Bowtie.Type.Kindcheck
 import Bowtie.Type.Parse (ParserErrorBundle)
 
 import qualified Bowtie.Core.Expr as Core
-import qualified Bowtie.Infer.Elaborate as Infer.Elaborate
+import qualified Bowtie.Infer.Elaborate as Elaborate
 import qualified Bowtie.Surface.AST as Surface
-import qualified Bowtie.Surface.Desugar as Surface.Desugar
+import qualified Bowtie.Surface.Desugar as Desugar
 import qualified Bowtie.Surface.Parse as Surface.Parse
-import qualified Bowtie.Untyped.Erase as Untyped.Erase
-import qualified Bowtie.Untyped.Eval as Untyped.Eval
+import qualified Bowtie.Untyped.Erase as Erase
+import qualified Bowtie.Untyped.Eval as Eval
 import qualified Bowtie.Untyped.Expr as Untyped
 import qualified Data.Bifunctor as Bifunctor
 import qualified Data.Text as Text
@@ -26,7 +26,7 @@ data IError
   deriving (Eq, Show)
 
 interpret :: Text -> Either IError Untyped.Expr
-interpret src = do
+interpret src =
   interpretProgram mempty ("<input>", src)
 
 interpretProgram
@@ -38,46 +38,15 @@ interpretProgram libFiles appFile = do
   let
     untyped :: Untyped.Expr
     untyped =
-      Untyped.Erase.erase core
+      Erase.erase core
 
-  case Untyped.Eval.eval mempty untyped of
+  case Eval.eval mempty untyped of
     Left e ->
       panic ("Evaluating failed (this should never happen): " <> show e)
 
     Right a ->
       pure a
 
-prettyError :: IError -> Text
-prettyError err =
-  case err of
-    ParseError e ->
-      "Parse error: " <> Text.pack (Mega.errorBundlePretty e)
-
-    NameClash t ->
-      t
-
-    TypeError e ->
-      "Type error: " <> show e
-
--- | NOTE: Environment is just the data types.
-sourceToCore :: Text -> Either IError (Environment, Core.Expr)
-sourceToCore src = do
-  ast <- Bifunctor.first ParseError (Surface.Parse.parse "<input>" src)
-  let
-    env :: Environment
-    env =
-      kindcheck (astTypes ast)
-
-    dsg :: Surface.Expr
-    dsg =
-      Surface.Desugar.desugarResult (astTerms ast)
-
-  (_, _, explicitlyTypedExpr) <- Bifunctor.first
-                                   TypeError
-                                   (Infer.Elaborate.elaborate env dsg)
-
-  pure (env, Surface.Desugar.dsg explicitlyTypedExpr)
-
 sourcesToAST :: HashMap FilePath Text -> (FilePath, Text) -> Either IError AST
 sourcesToAST libFiles appFile = do
   libPrograms <- Bifunctor.first ParseError (for (hashmapToSortedList libFiles) parse)
@@ -99,12 +68,12 @@ sourcesToCore libFiles appFile = do
 
     dsg :: Surface.Expr
     dsg =
-      Surface.Desugar.desugarResult (astTerms ast)
+      Desugar.extractResult (astTerms ast)
 
   (_, _, explicitlyTypedExpr) <- Bifunctor.first
                                    TypeError
-                                   (Infer.Elaborate.elaborate env dsg)
-  pure (env, Surface.Desugar.dsg explicitlyTypedExpr)
+                                   (Elaborate.elaborate env dsg)
+  pure (env, Desugar.desugar explicitlyTypedExpr)
 
 concatSource :: [AST] -> Either Text AST
 concatSource =
@@ -119,3 +88,15 @@ concatSource =
 
         Right a ->
           pure a
+
+prettyError :: IError -> Text
+prettyError err =
+  case err of
+    ParseError e ->
+      "Parse error: " <> Text.pack (Mega.errorBundlePretty e)
+
+    NameClash t ->
+      t
+
+    TypeError e ->
+      "Type error: " <> show e

bowtie/src/Bowtie/Surface/Desugar.hs

@@ -1,7 +1,7 @@
 module Bowtie.Surface.Desugar
-  ( dsg
-  , desugarResult
-  , desugarLet'
+  ( desugar
+  , extractResult
+  , flattenLetBindings
   ) where
 
 import Bowtie.Lib.FreeVars
@@ -18,36 +18,62 @@ import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 
-desugarResult :: OrderedMap Id (Expr, Type) -> Expr
-desugarResult decls =
+extractResult :: OrderedMap Id (Expr, Type) -> Expr
+extractResult decls =
   case OrderedMap.lookup (Id "result") decls of
     Nothing ->
       panic "result id not found"
 
     Just (resultExpr, _typ) ->
-      let
-        withoutRes :: OrderedMap Id (Expr, Type)
-        withoutRes =
-          OrderedMap.delete (Id "result") decls
-      in
-        Let withoutRes resultExpr
+      Let (OrderedMap.delete (Id "result") decls) resultExpr
+
+-- | Used by both inferece and desugaring to core.
+flattenLetBindings :: OrderedMap Id (Expr, Type) -> [(Id, (Expr, Type))]
+flattenLetBindings decls =
+  foldr f mempty components
+  where
+    components :: [Graph.SCC ((Expr, Type), Id, [Id])]
+    components =
+      Graph.stronglyConnCompR (fmap g (OrderedMap.toList decls))
+      where
+        g :: (Id, (Expr, Type)) -> ((Expr, Type), Id, [Id])
+        g (id, (expr, typ)) =
+          ((expr, typ), id, Set.toList (freeVars expr))
+
+    f :: Graph.SCC ((Expr, Type), Id, ids) -> [(Id, (Expr, Type))] -> [(Id, (Expr, Type))]
+    f grph acc =
+      case grph of
+        Graph.AcyclicSCC (expr, id, _) ->
+          (id, expr) : acc
+
+        Graph.CyclicSCC [(expr, id, _)] ->
+          -- Was
+          --
+          --   panic "cyclic"
+          --
+          -- I believe this needs to be let through though so that
+          -- functions can refer to themselves.
+          (id, expr) : acc
+
+        _ ->
+          panic "flattenLetBindings"
 
-dsg :: Expr -> Core.Expr
-dsg topExpr =
+desugar :: Expr -> Core.Expr
+desugar topExpr =
   case topExpr of
     Var i ->
       Core.Var i
 
     Lam id mType e ->
       case mType of
         Nothing ->
-          panic "dsg type is Nothing"
+          panic "desugar type is Nothing"
 
         Just typ ->
-          Core.Lam id typ (dsg e)
+          Core.Lam id typ (desugar e)
 
     App e1 e2 ->
-      Core.App (dsg e1) (dsg e2)
+      Core.App (desugar e1) (desugar e2)
 
     Let decls e ->
       desugarLet decls e
@@ -59,9 +85,9 @@ dsg topExpr =
       let
         f :: Alt -> Core.Alt
         f (Alt i i2 expr) =
-          Core.Alt i i2 (dsg expr)
+          Core.Alt i i2 (desugar expr)
       in
-        Core.Case (dsg e) (fmap f matches)
+        Core.Case (desugar e) (fmap f matches)
 
     EInt n ->
       Core.EInt n
@@ -96,37 +122,6 @@ desugarText =
       in
         Core.App consCodePoint expr
 
--- This one is used by both inferece and desugaring to core
-desugarLet' :: OrderedMap Id (Expr, Type) -> [(Id, (Expr, Type))]
-desugarLet' decls =
-  foldr f mempty components
-  where
-    components :: [Graph.SCC ((Expr, Type), Id, [Id])]
-    components =
-      Graph.stronglyConnCompR (fmap g (OrderedMap.toList decls))
-      where
-        g :: (Id, (Expr, Type)) -> ((Expr, Type), Id, [Id])
-        g (id, (expr, typ)) =
-          ((expr, typ), id, Set.toList (freeVars expr))
-
-    f :: Graph.SCC ((Expr, Type), Id, ids) -> [(Id, (Expr, Type))] -> [(Id, (Expr, Type))]
-    f grph acc =
-      case grph of
-        Graph.AcyclicSCC (expr, id, _) ->
-          (id, expr) : acc
-
-        Graph.CyclicSCC [(expr, id, _)] ->
-          -- Was
-          --
-          --   panic "cyclic"
-          --
-          -- I believe this needs to be let through though so that
-          -- functions can refer to themselves.
-          (id, expr) : acc
-
-        _ ->
-          panic "desugarLet'"
-
 -- This one isn't used for inference, but just going to core
 desugarLet :: OrderedMap Id (Expr, Type) -> Expr -> Core.Expr
 desugarLet decls e =
@@ -141,7 +136,7 @@ desugarLet decls e =
           -- By doing this here we replace their definitions in the
           -- source code with a new value.
           -- The old way of doing it was to case on id in the Lam
-          -- case of dsg, which replaced the call sites instead of
+          -- case of desugar, which replaced the call sites instead of
           -- the function definitions.
           case i of
             Id "compare" ->
@@ -220,8 +215,8 @@ desugarLet decls e =
                       (Core.Var a)))
 
             _ ->
-              dsg e2
+              desugar e2
       in
         Core.Let (HashMap.singleton i (e3, typ)) acc)
-    (dsg e)
-    (desugarLet' decls)
+    (desugar e)
+    (flattenLetBindings decls)

bowtie/test/Bowtie/Surface/InferSpec.hs

@@ -24,7 +24,7 @@ unitEnv =
 inferProgram :: AST -> Either TypeError Type
 inferProgram ast = do
   (_, b, _) <-
-    elaborate (kindcheck (astTypes ast)) (desugarResult (astTerms ast))
+    elaborate (kindcheck (astTypes ast)) (extractResult (astTerms ast))
   pure b
 
 infer :: Environment -> Expr -> Either TypeError (Substitution, Type)

bowtie/test/Test.hs

@@ -76,7 +76,7 @@ runInvalidSyntax (name, src) =
 runIllTyped :: (FilePath, Text) -> Spec
 runIllTyped (name, src) =
   it name $
-    case Interpret.sourceToCore src of
+    case Interpret.sourcesToCore mempty ("<input>", src) of
       Left err ->
         case err of
           Interpret.ParseError _ ->