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 qqName :: String
qqName correctCtx :: Ctx
correctCtx = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
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
ctx =
      "You have used the `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
qqName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "` QuasiQuoter " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      "in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ctx -> String
ctxName Ctx
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ " context; " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      "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]
++ " context"

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


toUnix :: String -> String
toUnix :: String -> String
toUnix cs :: String
cs = case String
cs of
  '\r':'\n' : cs :: String
cs -> '\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUnix String
cs
  '\r'      : cs :: String
cs -> '\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUnix String
cs
  c :: Char
c         : cs :: 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 "here" Ctx
Exp) { quoteExp :: String -> Q Exp
quoteExp  = Lit -> Q Exp
litE (Lit -> Q Exp) -> (String -> Lit) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Lit) -> (String -> String) -> String -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
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 "str" Ctx
Exp)
      { quoteExp :: String -> Q Exp
quoteExp = Lit -> Q Exp
litE (Lit -> Q Exp) -> (String -> Lit) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Lit) -> (String -> String) -> String -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
unPipe ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toUnix }
  where
    unPipe :: [String] -> [String]
unPipe ls :: [String]
ls = case [String]
ls of
      []     -> []
      l :: String
l : ls :: [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
        Nothing              -> []
        Just (middles :: [String]
middles, last :: 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 -> Maybe String
tryRemovePipe String
last)]
            where
            removePipe :: String -> String
removePipe cs :: String
cs = case String -> Maybe String
tryRemovePipe String
cs of
              Nothing -> String -> String
forall a. HasCallStack => String -> a
error "no pipe character found in line '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'"
              Just cs :: String
cs -> String
cs

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

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