module Text.Heredoc (here, there, str) where

import Data.Maybe (fromMaybe)
import Data.List (intercalate)
import Language.Haskell.TH
  ( litE
  , stringL
  )

import Language.Haskell.TH.Quote
  ( QuasiQuoter
    ( QuasiQuoter
    , quoteExp
    , quotePat
    , quoteType
    , quoteDec
    )
  , quoteFile
  )

data Ctx = Exp | Pat | Type | Dec

qq :: String -> Ctx -> QuasiQuoter
qq :: String -> Ctx -> QuasiQuoter
qq String
qqName Ctx
correctCtx = QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = Q Exp -> String -> Q Exp
forall a b. a -> b -> a
const (Q Exp -> String -> Q Exp) -> Q Exp -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Ctx -> String
errorString Ctx
Exp
  , quotePat :: String -> Q Pat
quotePat  = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. HasCallStack => String -> a
error (String -> Q Pat) -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ Ctx -> String
errorString Ctx
Pat
  , quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. HasCallStack => String -> a
error (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ Ctx -> String
errorString Ctx
Type
  , quoteDec :: String -> Q [Dec]
quoteDec  = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Ctx -> String
errorString Ctx
Dec
  }
  where
    errorString :: Ctx -> String
errorString Ctx
ctx =
      String
"You have used the `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
qqName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` QuasiQuoter " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ctx -> String
ctxName Ctx
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" context; " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"you must only use it in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ctx -> String
ctxName Ctx
correctCtx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" context"

    ctxName :: Ctx -> String
ctxName Ctx
c = case Ctx
c of
      Ctx
Exp  -> String
"an expression"
      Ctx
Pat  -> String
"a pattern"
      Ctx
Type -> String
"a type"
      Ctx
Dec  -> String
"a declaration"


toUnix :: String -> String
toUnix :: String -> String
toUnix String
cs = case String
cs of
  Char
'\r':Char
'\n' : String
cs -> Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUnix String
cs
  Char
'\r'      : String
cs -> Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUnix String
cs
  Char
c         : String
cs -> Char
c    Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUnix String
cs
  []             -> []

{-| Create a string-literal expression from the string being quoted.

    Newline literals are normalized to UNIX newlines (one '\n' character).
-}
here :: QuasiQuoter
here :: QuasiQuoter
here = (String -> Ctx -> QuasiQuoter
qq String
"here" Ctx
Exp) { quoteExp  = litE . stringL . toUnix }

{-| Create a string-literal expression from
    the contents of the file at the filepath being quoted.

    Newline literals are normalized to UNIX newlines (one '\n' character).
-}
there :: QuasiQuoter
there :: QuasiQuoter
there = QuasiQuoter -> QuasiQuoter
quoteFile QuasiQuoter
here

{-| Create a multi-line string literal whose left edge is demarcated by the
    "pipe" character ('|'). For example,

    >famousQuote = [str|Any dictator would admire the
    >                  |uniformity and obedience of the U.S. media.
    >                  |
    >                  |    -- Noam Chomsky
    >                  |]

    is functionally equivalent to

    >famousQuote = "Any dictator would admire the\n" ++
    >              "uniformity and obedience of the U.S. media.\n" ++
    >              "\n" ++
    >              "    -- Noam Chomsky\n"

    If desired, you can have a ragged left-edge, so

    >myHtml = [str|<html>
    >                 |<body>
    >                     |<h1>My home page</h1>
    >                 |</body>
    >             |</html>
    >             |]

    is functionally equivalent to

    >myHtml = "<html>\n" ++
    >         "<body>\n" ++
    >         "<h1>My home page</h1>\n" ++
    >          "</body>\n" ++
    >         "</html>\n"
-}
str :: QuasiQuoter
str :: QuasiQuoter
str = (String -> Ctx -> QuasiQuoter
qq String
"str" Ctx
Exp)
      { quoteExp = litE . stringL . intercalate "\n" . unPipe . lines . toUnix }
  where
    unPipe :: [String] -> [String]
unPipe [String]
ls = case [String]
ls of
      []     -> []
      String
l : [String]
ls -> String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: case [String] -> Maybe ([String], String)
forall a. [a] -> Maybe ([a], a)
splitLast [String]
ls of
        Maybe ([String], String)
Nothing              -> []
        Just ([String]
middles, String
last) ->
          (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
removePipe [String]
middles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (String -> Maybe String
tryRemovePipe String
last)]
            where
            removePipe :: String -> String
removePipe String
cs = case String -> Maybe String
tryRemovePipe String
cs of
              Maybe String
Nothing -> String -> String
forall a. HasCallStack => String -> a
error String
"no pipe character found in line '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
              Just String
cs -> String
cs

            tryRemovePipe :: String -> Maybe String
tryRemovePipe String
cs = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'|') String
cs of
              []   -> Maybe String
forall a. Maybe a
Nothing
              Char
c:String
cs -> String -> Maybe String
forall a. a -> Maybe a
Just String
cs

    splitLast :: [a] -> Maybe ([a], a)
    splitLast :: forall a. [a] -> Maybe ([a], a)
splitLast [a]
xs = case [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs of
      []  -> Maybe ([a], a)
forall a. Maybe a
Nothing
      a
l:[a]
i -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
i, a
l)