From eabd5b97e21e72fd1fb4968fbd0b7698f2cfb955 Mon Sep 17 00:00:00 2001
From: Timothy Clem <timothy.clem@gmail.com>
Date: Tue, 25 Sep 2018 14:00:39 -0500
Subject: [PATCH] Minor refactor so we still get errors when we want that
 behavior

---
 src/Semantic/Parse.hs | 51 +++++++++++++++++++++----------------------
 1 file changed, 25 insertions(+), 26 deletions(-)

diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs
index 84d662c21..ae5a391ba 100644
--- a/src/Semantic/Parse.hs
+++ b/src/Semantic/Parse.hs
@@ -21,40 +21,39 @@ import           Semantic.IO (noLanguageForBlob)
 import           Semantic.Task
 import           Serializing.Format
 
+-- | Using the specified renderer, parse a list of 'Blob's to produce a 'Builder' output.
 runParse :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => TermRenderer output -> [Blob] -> Eff effs Builder
-runParse JSONTermRenderer             = withParsedBlobs renderJSONError (render . renderJSONTerm) >=> serialize JSON
-runParse JSONGraphTermRenderer        = withParsedBlobs renderJSONError (render . renderAdjGraph) >=> serialize JSON
+runParse JSONTermRenderer             = withParsedBlobs' renderJSONError (render . renderJSONTerm) >=> serialize JSON
+runParse JSONGraphTermRenderer        = withParsedBlobs' renderJSONError (render . renderAdjGraph) >=> serialize JSON
   where renderAdjGraph :: (Recursive t, ToTreeGraph TermVertex (Base t)) => Blob -> t -> JSON.JSON "trees" SomeJSON
         renderAdjGraph blob term = renderJSONAdjTerm blob (renderTreeGraph term)
-runParse SExpressionTermRenderer      = withParsedBlobs (\_ _ -> mempty) (const (serialize (SExpression ByConstructorName)))
-runParse ShowTermRenderer             = withParsedBlobs (\_ _ -> mempty) (const (serialize Show . quieterm))
-runParse (SymbolsTermRenderer fields) = withParsedBlobs (\_ _ -> mempty) (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
-runParse DOTTermRenderer              = withParsedBlobs (\_ _ -> mempty) (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
-
+runParse SExpressionTermRenderer      = withParsedBlobs (const (serialize (SExpression ByConstructorName)))
+runParse ShowTermRenderer             = withParsedBlobs (const (serialize Show . quieterm))
+runParse (SymbolsTermRenderer fields) = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
+runParse DOTTermRenderer              = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
 
+-- | For testing and running parse-examples.
 runParse' :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs Builder
 runParse' blob = parseSomeBlob blob >>= withSomeTerm (serialize Show . quieterm)
 
-withParsedBlobs ::
-  ( Member Distribute effs
-  , Member (Exc SomeException) effs
-  , Member Task effs
-  , Monoid output
+type Render effs output = forall syntax .
+  ( ConstructorName syntax
+  , HasDeclaration syntax
+  , HasPackageDef syntax
+  , Foldable syntax
+  , Functor syntax
+  , Show1 syntax
+  , ToJSONFields1 syntax
   )
-  => (Blob -> String -> output)
-  -> ( forall syntax .
-        ( ConstructorName syntax
-        , Foldable syntax
-        , Functor syntax
-        , HasDeclaration syntax
-        , HasPackageDef syntax
-        , Show1 syntax
-        , ToJSONFields1 syntax
-        ) => Blob -> Term syntax Location -> Eff effs output
-      )
-  -> [Blob]
-  -> Eff effs output
-withParsedBlobs onError render = distributeFoldMap $ \blob ->
+  => Blob -> Term syntax Location -> Eff effs output
+
+withParsedBlobs :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output)
+  => Render effs output -> [Blob] -> Eff effs output
+withParsedBlobs render = distributeFoldMap $ \blob -> parseSomeBlob blob >>= withSomeTerm (render blob)
+
+withParsedBlobs' :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output)
+  => (Blob -> String -> output) -> Render effs output -> [Blob] -> Eff effs output
+withParsedBlobs' onError render = distributeFoldMap $ \blob ->
   (parseSomeBlob blob >>= withSomeTerm (render blob)) `catchError` \(SomeException e) ->
     pure (onError blob (show e))