Replace all usages of String with Text

rzk-js/Main.hs

@@ -6,6 +6,7 @@ import qualified GHCJS.Foreign.Callback as GHCJS
 import GHCJS.Marshal (fromJSVal, toJSVal)
 import GHCJS.Prim (JSVal)
 import Data.JSString(JSString, pack)
+import qualified Data.Text as T
 import JavaScript.Object
 import JavaScript.Object.Internal (Object (..), create)
 import qualified Rzk.Main as Rzk
@@ -23,8 +24,8 @@ main = do
     input <- maybe (Left "Could not turn JSRef to a String") Right <$> fromJSVal rawInput
 
     case Rzk.typecheckString =<< input of
-      Left err -> setStringProp "status" "error" o >> setStringProp "result" (pack err) o
-      Right ok -> setStringProp "status" "ok" o >> setStringProp "result" (pack ok) o
+      Left err -> setStringProp "status" "error" o >> setStringProp "result" (pack (T.unpack err)) o
+      Right ok -> setStringProp "status" "ok" o >> setStringProp "result" (pack (T.unpack ok)) o
 
   set_rzk_typecheck_callback callback
 

rzk-js/rzk-js.cabal

@@ -9,7 +9,7 @@ executable rzk-js
   main-is:             Main.hs
   ghcjs-options:
     -dedupe
-  build-depends:       base, rzk
+  build-depends:       base, rzk, text >=1.2.3.1
   if impl(ghcjs)
     build-depends:
       ghcjs-base, ghcjs-prim

rzk/Makefile

@@ -9,7 +9,7 @@ clean:
 
 src/Language/Rzk/Syntax/Test: src/Language/Rzk/Syntax.cf
 	cd src/ \
-		&& bnfc -d Language/Rzk/Syntax.cf -p Language.Rzk --makefile=Language/Rzk/Makefile --generic --functor \
+		&& bnfc -d Language/Rzk/Syntax.cf -p Language.Rzk --makefile=Language/Rzk/Makefile --generic --functor --text-token \
 		&& make --makefile=Language/Rzk/Makefile \
 		&& rm Language/Rzk/Syntax/Test.hs ; \
 		cd ../

rzk/Setup.hs

@@ -20,7 +20,7 @@ main = defaultMainWithHooks $ simpleUserHooks
   { hookedPrograms = [ bnfcProgram ]
   , postConf       = \args flags packageDesc localBuildInfo -> do
 #ifndef mingw32_HOST_OS
-      _ <- system "bnfc -d -p Language.Rzk --generic --functor -o src/ grammar/Syntax.cf"
+      _ <- system "bnfc -d -p Language.Rzk --generic --functor --text-token -o src/ grammar/Syntax.cf"
 #endif
       postConf simpleUserHooks args flags packageDesc localBuildInfo
   }

rzk/app/Main.hs

@@ -2,18 +2,17 @@
 {-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 module Main (main) where
 
 #ifndef __GHCJS__
-import           Main.Utf8 (withUtf8)
+import           Main.Utf8               (withUtf8)
 #endif
 
-import           Control.Monad           (forM, forM_, unless, when,
-                                          (>=>))
+import           Control.Monad           (forM, forM_, unless, when, (>=>))
 import           Data.Version            (showVersion)
 
 #ifdef LSP
@@ -24,11 +23,13 @@ import           Options.Generic
 import           System.Exit             (exitFailure, exitSuccess)
 
 import           Data.Functor            (void, (<&>))
+import qualified Data.Text.IO            as T
+
 import           Paths_rzk               (version)
 import           Rzk.Format              (formatFile, formatFileWrite,
                                           isWellFormattedFile)
-import           Rzk.TypeCheck
 import           Rzk.Main
+import           Rzk.TypeCheck
 
 data FormatOptions = FormatOptions
   { check :: Bool
@@ -78,7 +79,7 @@ main = do
       case expandedPaths of
         [] -> error "No files found"
         filePaths -> do
-          when (not check && not write) $ forM_ filePaths (formatFile >=> putStrLn)
+          when (not check && not write) $ forM_ filePaths (formatFile >=> T.putStrLn)
           when write $ forM_ filePaths formatFileWrite
           when check $ do
             results <- forM filePaths $ \path -> isWellFormattedFile path <&> (path,)

rzk/src/Language/Rzk/Free/Syntax.hs

@@ -19,6 +19,7 @@ import           Data.Functor        (void)
 import           Data.List           (intercalate, nub, (\\))
 import           Data.Maybe          (fromMaybe)
 import           Data.String
+import qualified Data.Text           as T
 
 import           Free.Scoped
 import           Free.Scoped.TH
@@ -428,28 +429,28 @@ incVarIdentIndex (VarIdent (Rzk.VarIdent loc token)) =
 
 -- | Increment the subscript number at the end of the indentifier.
 --
--- >>> putStrLn $ incIndex "x"
+-- >>> putStrLn $ T.unpack $ incIndex "x"
 -- x₁
--- >>> putStrLn $ incIndex "x₁₉"
+-- >>> putStrLn $ T.unpack $ incIndex "x₁₉"
 -- x₂₀
-incIndex :: String -> String
-incIndex s = name <> newIndex
+incIndex :: T.Text -> T.Text
+incIndex s = T.pack $ name <> newIndex
   where
     digitsSub = "₀₁₂₃₄₅₆₇₈₉" :: String
     isDigitSub = (`elem` digitsSub)
     digitFromSub c = chr ((ord c - ord '₀') + ord '0')
     digitToSub c = chr ((ord c - ord '0') + ord '₀')
-    (name, index) = break isDigitSub s
+    (name, index) = break isDigitSub (T.unpack s)
     oldIndexN = read ('0' : map digitFromSub index) -- FIXME: read
     newIndex = map digitToSub (show (oldIndexN + 1))
 
 instance Show Term' where
   show = Rzk.printTree . fromTerm'
 
 instance IsString Term' where
-  fromString = toTerm' . fromRight . Rzk.parseTerm
+  fromString = toTerm' . fromRight . Rzk.parseTerm . T.pack
     where
-      fromRight (Left err) = error ("Parse error: " <> err)
+      fromRight (Left err) = error (T.unpack $ "Parse error: " <> err)
       fromRight (Right t)  = t
 
 instance Show TermT' where

rzk/src/Language/Rzk/Syntax.hs

@@ -21,48 +21,49 @@ import           Control.Exception          (Exception (..), SomeException,
                                              evaluate, try)
 
 import           Data.Char                  (isSpace)
-import qualified Data.List                  as List
+import qualified Data.Text                  as T
 
 import           Language.Rzk.Syntax.Abs
 import qualified Language.Rzk.Syntax.Layout as Layout
 import qualified Language.Rzk.Syntax.Print  as Print
 
-import           Language.Rzk.Syntax.Lex    (tokens, Token)
+import           Control.Arrow              (ArrowChoice (left))
+import           GHC.IO                     (unsafePerformIO)
+import           Language.Rzk.Syntax.Lex    (Token, tokens)
 import           Language.Rzk.Syntax.Par    (pModule, pTerm)
-import GHC.IO (unsafePerformIO)
 
-tryOrDisplayException :: Either String a -> IO (Either String a)
+tryOrDisplayException :: Either T.Text a -> IO (Either T.Text a)
 tryOrDisplayException = tryOrDisplayExceptionIO . evaluate
 
-tryOrDisplayExceptionIO :: IO (Either String a) -> IO (Either String a)
+tryOrDisplayExceptionIO :: IO (Either T.Text a) -> IO (Either T.Text a)
 tryOrDisplayExceptionIO x =
   try x >>= \case
-    Left (ex :: SomeException) -> return (Left (displayException ex))
+    Left (ex :: SomeException) -> return (Left (T.pack $ displayException ex))
     Right result               -> return result
 
-parseModuleSafe :: String -> IO (Either String Module)
+parseModuleSafe :: T.Text -> IO (Either T.Text Module)
 parseModuleSafe = tryOrDisplayException . parseModule
 
-parseModule :: String -> Either String Module
-parseModule = pModule . Layout.resolveLayout True . tokens . tryExtractMarkdownCodeBlocks "rzk"
+parseModule :: T.Text -> Either T.Text Module
+parseModule = left T.pack . pModule . Layout.resolveLayout True . tokens . tryExtractMarkdownCodeBlocks "rzk"
 
-parseModuleRzk :: String -> Either String Module
-parseModuleRzk = pModule . Layout.resolveLayout True . tokens
+parseModuleRzk :: T.Text -> Either T.Text Module
+parseModuleRzk = left T.pack . pModule . Layout.resolveLayout True . tokens
 
-parseModuleFile :: FilePath -> IO (Either String Module)
+parseModuleFile :: FilePath -> IO (Either T.Text Module)
 parseModuleFile path = do
   source <- readFile path
-  parseModuleSafe source
+  parseModuleSafe (T.pack source)
 
-parseTerm :: String -> Either String Term
-parseTerm = pTerm . tokens
+parseTerm :: T.Text -> Either T.Text Term
+parseTerm = left T.pack . pTerm . tokens
 
-tryExtractMarkdownCodeBlocks :: String -> String -> String
+tryExtractMarkdownCodeBlocks :: T.Text -> T.Text -> T.Text
 tryExtractMarkdownCodeBlocks alias input
-  | ("```" <> alias <> "\n") `List.isInfixOf` input = extractMarkdownCodeBlocks alias input
+  | ("```" <> alias <> "\n") `T.isInfixOf` input = extractMarkdownCodeBlocks alias input
   | otherwise = input
 
-data LineType = NonCode | CodeOf String
+data LineType = NonCode | CodeOf T.Text
 
 -- | Extract code for a given alias (e.g. "rzk" or "haskell") from a Markdown file
 -- by replacing any lines that do not belong to the code in that language with blank lines.
@@ -86,7 +87,7 @@ data LineType = NonCode | CodeOf String
 --   := U
 -- ```
 -- asda
--- >>> putStrLn $ extractMarkdownCodeBlocks "rzk" example
+-- >>> putStrLn $ T.unpack $ extractMarkdownCodeBlocks "rzk" example
 -- <BLANKLINE>
 -- <BLANKLINE>
 -- #lang rzk-1
@@ -98,8 +99,8 @@ data LineType = NonCode | CodeOf String
 -- <BLANKLINE>
 -- <BLANKLINE>
 -- <BLANKLINE>
-extractMarkdownCodeBlocks :: String -> String -> String
-extractMarkdownCodeBlocks alias = unlines . blankNonCode NonCode . map trim . lines
+extractMarkdownCodeBlocks :: T.Text -> T.Text -> T.Text
+extractMarkdownCodeBlocks alias = T.unlines . blankNonCode NonCode . map trim . T.lines
   where
     blankNonCode _prevType [] = []
     blankNonCode prevType (line : lines_) =
@@ -110,19 +111,20 @@ extractMarkdownCodeBlocks alias = unlines . blankNonCode NonCode . map trim . li
           | otherwise     -> ""   : blankNonCode prevType lines_
         NonCode -> "" : blankNonCode (identifyCodeBlockStart line) lines_
 
-    trim = List.dropWhileEnd isSpace
+    trim = T.dropWhileEnd isSpace
 
-identifyCodeBlockStart :: String -> LineType
+identifyCodeBlockStart :: T.Text -> LineType
 identifyCodeBlockStart line
   | prefix == "```" =
-      case words suffix of
-        []                          -> CodeOf "text" -- default to text
-        ('{':'.':lang) : _options   -> CodeOf lang   -- ``` {.rzk ...
-        "{" : ('.':lang) : _options -> CodeOf lang   -- ``` { .rzk ...
-        lang : _options             -> CodeOf lang   -- ```rzk ...
+      -- TODO: find if there is a better way to pattern match than pack/unpack
+      case map T.unpack $ T.words suffix of
+        []                           -> CodeOf "text" -- default to text
+        ('{': '.' : lang) : _options -> CodeOf (T.pack lang)   -- ``` {.rzk ...
+        "{" : ('.':lang) : _options  -> CodeOf (T.pack lang)   -- ``` { .rzk ...
+        lang : _options              -> CodeOf (T.pack lang)   -- ```rzk ...
   | otherwise = NonCode
   where
-    (prefix, suffix) = List.splitAt 3 line
+    (prefix, suffix) = T.splitAt 3 line
 
 -- * Making BNFC resolveLayout safer