string_interpolation.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.List (intersperse)
import Data.Semigroup (Endo (..))
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Lazy qualified as Text.Lazy
import Data.Text.Lazy.Builder qualified as Text (Builder)
import Data.Text.Lazy.Builder qualified as Text.Builder
import GHC.Float (floatToDigits)

{----- Machinery -----}

-- | Laws:
--     * fromBuilder . toBuilder === id
--     * toBuilder . fromBuilder === id
class Monoid (Builder s) => Buildable s where
  type Builder s = r | r -> s
  toBuilder :: s -> Builder s
  fromBuilder :: Builder s -> s

class Buildable s => Interpolate a s where
  interpolate :: a -> Builder s

{----- String instances -----}

newtype StringBuilder = StringBuilder (Endo String)
  deriving newtype (Semigroup, Monoid)

instance Buildable String where
  type Builder String = StringBuilder
  toBuilder s = StringBuilder (Endo (s ++))
  fromBuilder (StringBuilder (Endo f)) = f []

instance Interpolate String String where
  interpolate = toBuilder
instance {-# OVERLAPPABLE #-} Show a => Interpolate a String where
  interpolate = StringBuilder . Endo . shows

{----- Text instances -----}

instance Buildable Text where
  type Builder Text = Text.Builder
  toBuilder = Text.Builder.fromText
  fromBuilder = Text.Lazy.toStrict . Text.Builder.toLazyText

instance Interpolate Text Text where
  interpolate = toBuilder
instance {-# OVERLAPPABLE #-} Show a => Interpolate a Text where
  interpolate = interpolate . show

instance Interpolate String Text where
  interpolate = interpolate . Text.pack
instance Interpolate Text String where
  interpolate = interpolate . Text.unpack

{----- New SqlQuery type -----}

data SqlQuery = SqlQuery
  { sqlText :: Text
  , sqlValues :: [SqlValue]
  }
  deriving (Show)

instance IsString SqlQuery where
  fromString s = SqlQuery{sqlText = Text.pack s, sqlValues = []}
instance Semigroup SqlQuery where
  q1 <> q2 =
    SqlQuery
      { sqlText = sqlText q1 <> sqlText q2
      , sqlValues = sqlValues q1 <> sqlValues q2
      }
instance Monoid SqlQuery where
  mempty =
    SqlQuery
      { sqlText = ""
      , sqlValues = []
      }

data SqlValue
  = SqlText Text
  | SqlInt Int
  deriving (Show)

newtype SqlQueryBuilder = SqlQueryBuilder (Endo SqlQuery)
  deriving newtype (Semigroup, Monoid)

instance Buildable SqlQuery where
  type Builder SqlQuery = SqlQueryBuilder
  toBuilder q = SqlQueryBuilder (Endo (q <>))
  fromBuilder (SqlQueryBuilder (Endo f)) = f mempty

instance Interpolate SqlQuery SqlQuery where
  interpolate = toBuilder
instance Interpolate Text SqlQuery where
  interpolate s = toBuilder SqlQuery{sqlText = "?", sqlValues = [SqlText s]}
instance Interpolate String SqlQuery where
  interpolate = interpolate . Text.pack
instance Interpolate Int SqlQuery where
  interpolate x = toBuilder SqlQuery{sqlText = "?", sqlValues = [SqlInt x]}

{----- New HTML type -----}

newtype Html = Html Text
  deriving newtype (Show, IsString, Semigroup, Monoid)

escapeHtml :: Text -> Text
escapeHtml = Text.replace "<" "&lt;" . Text.replace ">" "&gt;"

newtype RawHtml = RawHtml {unRawHtml :: Text}

newtype HtmlBuilder = HtmlBuilder (Endo Html)
  deriving newtype (Semigroup, Monoid)

instance Buildable Html where
  type Builder Html = HtmlBuilder
  toBuilder s = HtmlBuilder (Endo (s <>))
  fromBuilder (HtmlBuilder (Endo f)) = f mempty

instance Interpolate String Html where
  interpolate = interpolate . Text.pack
instance Interpolate Text Html where
  interpolate = toBuilder . Html . escapeHtml
instance Interpolate RawHtml Html where
  interpolate = toBuilder . Html . unRawHtml
instance {-# OVERLAPPABLE #-} Show a => Interpolate a Html where
  interpolate = interpolate . show

{----- BigDecimal -----}

data BigDecimal = BigDecimal Integer Int

renderBigDecimal :: BigDecimal -> String
renderBigDecimal (BigDecimal digits scale) =
  let (int, frac) = splitAt scale (show digits)
   in int <> "." <> frac

instance Interpolate BigDecimal String where
  interpolate = interpolate . renderBigDecimal
instance Interpolate BigDecimal Text where
  interpolate = interpolate . Text.pack . renderBigDecimal

{----- Precision -----}

data Precision a = Prec Int a
instance Interpolate (Precision Int) String where
  interpolate = interpolateInt
instance Interpolate (Precision Integer) String where
  interpolate = interpolateInt
instance Interpolate (Precision Double) String where
  interpolate = interpolateRealFloat
instance Interpolate (Precision Float) String where
  interpolate = interpolateRealFloat

interpolateInt :: (Interpolate String s, Integral a) => Precision a -> Builder s
interpolateInt (Prec scale n) = interpolate $ show (toInteger n) <> ('.' : replicate scale '0')

interpolateRealFloat :: (Interpolate String s, RealFloat a) => Precision a -> Builder s
interpolateRealFloat (Prec scale n) =
  let (digits, e) = floatToDigits 10 n
      (int, frac) = splitAt e digits
   in interpolate . concat $ map show int <> ["."] <> (map show . take scale) (frac <> repeat 0)

{----- Entrypoint -----}

main :: IO ()
main = do
  let x = "hello" :: String

  -- s"${x} world"
  print @String $
    fromBuilder $
      toBuilder ""
      <> interpolate x <> toBuilder " world"

  -- s"world ${x}"
  print @String $
    fromBuilder $
      toBuilder "world "
      <> interpolate x <> toBuilder ""

  -- s"${x} world"
  print @Text $
    fromBuilder $
      toBuilder ""
      <> interpolate x <> toBuilder " world"

  -- s"world ${x}"
  print @Text $
    fromBuilder $
      toBuilder "world "
      <> interpolate x <> toBuilder ""

  -- s"1 + 1 = ${2 :: Int}"
  print @Text $
    fromBuilder $
      toBuilder "1 + 1 = "
      <> interpolate (2 :: Int) <> toBuilder ""

  -- s"SELECT * FROM tab WHERE age = ${age} AND name ILIKE ${name}"
  let age = 10 :: Int
  let name = "Robert'); DROP TABLE Students;--" :: String
  print @SqlQuery $
    fromBuilder $
      toBuilder "SELECT * FROM tab WHERE age = "
      <> interpolate age <> toBuilder " AND name ILIKE "
      <> interpolate name <> toBuilder ""

  -- s"SELECT * FROM tab WHERE ${conjoin whereClauses}"
  let
    isAdult = True
    nameFilter = SqlText "A%"
    whereClauses =
      concat
        [ ["age > 18" | isAdult]
        , [SqlQuery{sqlText = "name ILIKE ?", sqlValues = [nameFilter]}]
        ]
    conjoin cs = mconcat $ intersperse " AND " (cs :: [SqlQuery])
  print @SqlQuery $
    fromBuilder $
      toBuilder "SELECT * FROM tab WHERE "
      <> interpolate (conjoin whereClauses) <> toBuilder ""

  -- s"<h1>${title}</h1>${RawHtml body}"
  let title = "Why is 1 > 0?" :: Text
  let body = "<p>Hello world</p>" :: Text
  print @Html $
    fromBuilder $
      toBuilder "<h1>"
      <> interpolate title <> toBuilder "</h1>"
      <> interpolate (RawHtml body) <> toBuilder ""

  -- s"123456 / 10^3 = ${n}"
  let n = BigDecimal 123456 3
  print @String $
    fromBuilder $
      toBuilder "123456 / 10^3 = "
      <> interpolate n <> toBuilder ""

  -- @"${Prec 3 x}"
  let x = 1.2 :: Double
  print @String $
    fromBuilder $
      toBuilder ""
      <> interpolate (Prec 3 x) <> toBuilder ""