    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)