Monadic error handling

1 files changed, 28 insertions, 19 deletions

diff --git a/src/parser.hs b/src/parser.hs
index f6883da..e1bea13 100644
--- a/src/parser.hs
+++ b/src/parser.hs
@@ -1,5 +1,6 @@
 module Parser where
 
+import Control.Monad.Except
 import qualified Data.Bifunctor as B
 import qualified Data.Hashable as DH
 import Data.List (intercalate, isInfixOf, isPrefixOf)
@@ -23,46 +24,54 @@ removeComments source =
 
 processStringLiterals = processStringLiterals' Nothing M.empty
 
-processStringLiterals' :: Maybe String -> Map String [LWord] -> String -> (String, Map String [LWord])
+processStringLiterals' :: Maybe String -> Map String [LWord] -> String -> ExceptT LException IO (String, Map String [LWord])
 processStringLiterals' currentM refMap [] = case currentM of
-  Just _ -> error "[error] nonterminated string literal"
-  Nothing -> ([], refMap)
+  Just _ -> throwError $ LException "nonterminated string literal"
+  Nothing -> pure ([], refMap)
 processStringLiterals' currentM refMap (c : source) = case c of
   '"' -> case currentM of
-    Just str ->
+    Just str -> do
       -- string literal ends
       let hash = DH.hash str $> show
-          strP = str $> map LChar .> LPhrase
-          interpolated = processSLInterpolations strP
-          newRefMap = M.insert hash interpolated refMap
-          (resSource, resRefMap) = processStringLiterals' Nothing newRefMap source
-       in ("##" ++ hash ++ resSource, resRefMap)
+      let strP = str $> map LChar .> LPhrase
+      interpolated <- processSLInterpolations strP
+      let newRefMap = M.insert hash interpolated refMap
+      (resSource, resRefMap) <- processStringLiterals' Nothing newRefMap source
+      pure ("##" ++ hash ++ resSource, resRefMap)
     Nothing ->
       -- string literal starts
       processStringLiterals' (Just "") refMap source
   other -> case currentM of
-    Just str -> processStringLiterals' (Just $ str ++ [c]) refMap source -- add char to current string literal
-    Nothing -> processStringLiterals' Nothing refMap source $> B.first (c :) -- proceed normally
+    Just str ->
+      -- add char to current string literal
+      processStringLiterals' (Just $ str ++ [c]) refMap source
+    Nothing ->
+      -- proceed normally
+      processStringLiterals' Nothing refMap source $> fmap (B.first (c :))
 
-processSLInterpolations :: LWord -> [LWord]
+processSLInterpolations :: LWord -> ExceptT LException IO [LWord]
 processSLInterpolations strP@(LPhrase lChars)
-  | "%%" `isInfixOf` chars = [LPhrase interpolated, LSymbol "unphrase"]
-  | otherwise = [strP]
+  | "%%" `isInfixOf` chars = pure [LPhrase interpolated, LSymbol "unphrase"]
+  | otherwise = pure [strP]
   where
     chars = lChars $> map (\(LChar c) -> c)
-    tChars = T.pack chars
+    -- split string on the %% marker into n substrings
     separatedByMarker = T.pack chars $> T.splitOn (T.pack "%%") .> map (T.unpack .> map LChar)
     labelIndices = [0 .. length separatedByMarker - 1 - 1]
+    -- store n - 1 variables from stack
     varStores = labelIndices $> map (\n -> [LLabel ("$__" ++ show n), LSymbol "!"]) .> reverse
     part1 = concat varStores
+    -- interleave the n substrings and n - 1 variable reads
     symbolLookups = labelIndices $> map (\n -> [LLabel ("$__" ++ show n), LSymbol "@", LSymbol "unphrase"])
     part2 = LSymbol "'[" : concat (mix separatedByMarker symbolLookups) ++ [LSymbol "']", LSymbol "phrase"]
+    -- forget the temp variables used
     varForgets = labelIndices $> map (\n -> [LLabel ("$__" ++ show n), LSymbol "forget"])
     part3 = concat varForgets
+    -- combine everything into one phrase
     interpolated = part1 ++ part2 ++ part3
-processSLInterpolations p = error $ "[error] non-phrase in processSLInterpolations: " ++ show p
+processSLInterpolations p = throwError $ LException $ "non-phrase in processSLInterpolations: " ++ show p
 
-parseSource source =
+parseSource source = do
   let woComments = source $> removeComments
-      (woStringLiterals, stringLiteralRefMap) = processStringLiterals woComments
-   in (woStringLiterals $> words .> map parseWord, stringLiteralRefMap)
+  (woStringLiterals, stringLiteralRefMap) <- processStringLiterals woComments
+  pure (woStringLiterals $> words .> map parseWord, stringLiteralRefMap)