From e55a21280d255399e9d1f1979f2035fc9ead8666 Mon Sep 17 00:00:00 2001
From: Jan Tuomi <jans.tuomi@gmail.com>
Date: Mon, 31 Jan 2022 23:26:13 +0200
Subject: Format strings with fmt

---
 src/interpreter.hs | 29 +++++++++++++++++------------
 src/main.hs        |  6 +++---
 src/parser.hs      | 15 ++++++++-------
 src/utils.hs       | 13 +++++++++++++
 4 files changed, 41 insertions(+), 22 deletions(-)

(limited to 'src')

diff --git a/src/interpreter.hs b/src/interpreter.hs
index fb3b34a..cb71c62 100644
--- a/src/interpreter.hs
+++ b/src/interpreter.hs
@@ -18,13 +18,13 @@ debugWaitForChar Config {configDebugMode = mode} = do
 
 debugPrint Config {configDebugMode = mode} message =
   if mode
-    then liftIO $ putStrLn $ "[debug] " ++ message
+    then liftIO $ putStrLn $ fmt "[debug] %%" [message]
     else pure ()
 
 interpretSource :: Config -> LState -> ExceptT LException IO LState
 interpretSource config state@LState {lSource = []} = pure state
 interpretSource config state@LState {lSource = (word : rest)} = do
-  liftIO $ debugPrint config $ "processing " ++ show word ++ ", current state ="
+  liftIO $ debugPrint config $ fmt "processing %%, current state =" [show word]
   liftIO $ debugState config state
   newState <- interpretWord state {lSource = rest} word
   step <- liftIO $ debugWaitForChar config
@@ -111,7 +111,7 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras
             (wordP, stack') <- consume1 LPhraseT stack
             let LPhrase ws = wordP
             let isLChar w = case w of LChar _ -> True; _ -> False
-            unless (all isLChar ws) $ throwError $ LException $ "cannot string-print heterogenous or non-string phrase: " ++ reprWord wordP
+            unless (all isLChar ws) $ throwError $ LException $ fmt "cannot string-print heterogenous or non-string phrase: %%" [reprWord wordP]
             let stringRepr = ws $> map (\(LChar c) -> c)
             liftIO . putStrLn $ stringRepr
             pure $ state {lStack = stack'}
@@ -181,26 +181,31 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras
           "loop" -> do
             (bodyP, condP, stack') <- consume2 LPhraseT LPhraseT stack
             let (LPhrase body, LPhrase cond) = (bodyP, condP)
-            let ifWords = cond ++ [LPhrase (body ++ [condP, bodyP, LSymbol "loop"])] ++ [LPhrase [], LSymbol "cond"]
+            let ifWords =
+                  concat
+                    [ cond,
+                      [LPhrase (body ++ [condP, bodyP, LSymbol "loop"])],
+                      [LPhrase [], LSymbol "cond"]
+                    ]
             let newSource = ifWords ++ source
             pure $ state {lStack = stack', lSource = newSource}
-          _ -> throwError $ LException $ "not defined: " ++ symbol
+          _ -> throwError $ LException $ fmt "not defined: %%" [symbol]
   | otherwise = pure $ state {lStack = word : stack}
 
 lAddNumbers :: LWord -> LWord -> ExceptT LException IO LWord
 lAddNumbers (LInteger a) (LInteger b) = pure $ LInteger (a + b)
 lAddNumbers (LFloat a) (LFloat b) = pure $ LFloat (a + b)
-lAddNumbers a b = throwError $ LException $ "sum is not defined for " ++ show a ++ ", " ++ show b
+lAddNumbers a b = throwError $ LException $ fmt "sum is not defined for %%, %%" [show a, show b]
 
 lSubNumbers :: LWord -> LWord -> ExceptT LException IO LWord
 lSubNumbers (LInteger a) (LInteger b) = pure $ LInteger (a - b)
 lSubNumbers (LFloat a) (LFloat b) = pure $ LFloat (a - b)
-lSubNumbers a b = throwError $ LException $ "difference is not defined for " ++ show a ++ ", " ++ show b
+lSubNumbers a b = throwError $ LException $ fmt "difference is not defined for %%, %%" [show a, show b]
 
 lMultiplyNumbers :: LWord -> LWord -> ExceptT LException IO LWord
 lMultiplyNumbers (LInteger a) (LInteger b) = pure $ LInteger (a * b)
 lMultiplyNumbers (LFloat a) (LFloat b) = pure $ LFloat (a * b)
-lMultiplyNumbers a b = throwError $ LException $ "product is not defined for " ++ show a ++ ", " ++ show b
+lMultiplyNumbers a b = throwError $ LException $ fmt "product is not defined for %%, %%" [show a, show b]
 
 lDivideNumbers :: LWord -> LWord -> ExceptT LException IO LWord
 lDivideNumbers (LInteger a) (LInteger b) =
@@ -211,18 +216,18 @@ lDivideNumbers (LFloat a) (LFloat b) =
   case b of
     0 -> throwError $ LException "division by zero"
     _ -> pure $ LFloat (a / b)
-lDivideNumbers a b = throwError $ LException $ "division is not defined for " ++ show a ++ ", " ++ show b
+lDivideNumbers a b = throwError $ LException $ fmt "division is not defined for %%, %%" [show a, show b]
 
 lGreaterThan :: LWord -> LWord -> ExceptT LException IO LWord
 lGreaterThan (LInteger a) (LInteger b) = pure $ LBool (a > b)
 lGreaterThan (LFloat a) (LFloat b) = pure $ LBool (a > b)
-lGreaterThan a b = throwError $ LException $ "greater-than is not defined for " ++ show a ++ ", " ++ show b
+lGreaterThan a b = throwError $ LException $ fmt "greater-than is not defined for %%, %%" [show a, show b]
 
 lLesserThan :: LWord -> LWord -> ExceptT LException IO LWord
 lLesserThan (LInteger a) (LInteger b) = pure $ LBool (a < b)
 lLesserThan (LFloat a) (LFloat b) = pure $ LBool (a < b)
-lLesserThan a b = throwError $ LException $ "lesser-than is not defined for " ++ show a ++ ", " ++ show b
+lLesserThan a b = throwError $ LException $ fmt "lesser-than is not defined for %%, %%" [show a, show b]
 
 lModNumbers :: LWord -> LWord -> ExceptT LException IO LWord
 lModNumbers (LInteger a) (LInteger b) = pure $ LInteger (a `mod` b)
-lModNumbers a b = throwError $ LException $ "modulo is not defined for " ++ show a ++ ", " ++ show b
+lModNumbers a b = throwError $ LException $ fmt "modulo is not defined for %%, %%" [show a, show b]
diff --git a/src/main.hs b/src/main.hs
index e23dcf3..b596a84 100644
--- a/src/main.hs
+++ b/src/main.hs
@@ -38,11 +38,11 @@ bootstrap args = do
   let config = getConfig initialConfig args
   fileName <- getFileName config
 
-  debugPrint config $ "executing file " ++ fileName ++ "\n"
+  debugPrint config $ fmt "executing file %%\n" [fileName]
   source <- liftIO . readFile $ fileName
   (parsedSource, strLitRefMap) <- parseSource source
-  debugPrint config $ "parsed words:\n" ++ show parsedSource ++ "\n"
-  debugPrint config $ "string literal refmap:\n" ++ show strLitRefMap ++ "\n"
+  debugPrint config $ fmt "parsed words:\n%%\n" [show parsedSource]
+  debugPrint config $ fmt "string literal refmap:\n%%\n" [show strLitRefMap]
   debugPrint config "interpreter output:"
   let initialState =
         LState
diff --git a/src/parser.hs b/src/parser.hs
index 9a24fda..679f318 100644
--- a/src/parser.hs
+++ b/src/parser.hs
@@ -18,9 +18,8 @@ parseWord rawStr
   | "$" `isPrefixOf` rawStr = LLabel $ tail rawStr
   | otherwise = LSymbol rawStr
 
-removeComments source =
-  let lines_ = lines source $> map (T.pack .> T.splitOn (T.pack "--") .> head .> T.unpack)
-   in unlines lines_
+removeComments =
+  lines .> map (T.pack .> T.splitOn (T.pack "--") .> head .> T.unpack) .> unlines
 
 processStringLiterals :: Maybe String -> Map String [LWord] -> String -> ExceptT LException IO (String, Map String [LWord])
 processStringLiterals currentM refMap [] = case currentM of
@@ -47,6 +46,8 @@ processStringLiterals currentM refMap (c : source) = case c of
       -- proceed normally
       processStringLiterals Nothing refMap source $> fmap (B.first (c :))
 
+internalNVar n = LLabel $ fmt "$__%%" [show n]
+
 processSLInterpolations :: LWord -> ExceptT LException IO [LWord]
 processSLInterpolations strP@(LPhrase lChars)
   | "%%" `isInfixOf` chars = pure [LPhrase interpolated, LSymbol "unphrase"]
@@ -57,17 +58,17 @@ processSLInterpolations strP@(LPhrase lChars)
     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
+    varStores = labelIndices $> map (\n -> [internalNVar 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"])
+    symbolLookups = labelIndices $> map (\n -> [internalNVar 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"])
+    varForgets = labelIndices $> map (\n -> [internalNVar n, LSymbol "forget"])
     part3 = concat varForgets
     -- combine everything into one phrase
     interpolated = part1 ++ part2 ++ part3
-processSLInterpolations p = throwError $ LException $ "non-phrase in processSLInterpolations: " ++ show p
+processSLInterpolations p = throwError $ LException $ fmt "non-phrase in processSLInterpolations: %%" [show p]
 
 parseSource source = do
   let woComments = source $> removeComments
diff --git a/src/utils.hs b/src/utils.hs
index 252804f..96f5fcb 100644
--- a/src/utils.hs
+++ b/src/utils.hs
@@ -2,6 +2,8 @@ module Utils where
 
 import Control.Monad.Except
 import qualified Data.Bifunctor as B
+import Data.Text (Text)
+import qualified Data.Text as T
 
 (.>) = flip (.)
 
@@ -51,3 +53,14 @@ safeBreak' _ ex _ [] = throwError ex
 safeBreak' cond ex acc lst@(x : xs)
   | cond x = pure (reverse acc, lst)
   | otherwise = safeBreak' cond ex (x : acc) xs
+
+fmt :: String -> [String] -> String
+fmt str values = T.unpack $ fmt' (T.pack str) (map T.pack values)
+
+fmt' :: Text -> [Text] -> Text
+fmt' text [] = text
+fmt' text (v : rest) =
+  let pattern = T.pack "%%"
+      (front, back) = T.breakOn pattern text
+      res = T.concat [front, v, T.drop (T.length pattern) back]
+   in fmt' res rest
-- 
cgit v1.3