{-|
Copyright  :  (C) 2019, QBayLogic B.V.
                  2013, Nikita Volkov
License    :  BSD2 (see the file LICENSE)
Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
-}

{-
This is an adaptation of

  https://github.com/nikita-volkov/neat-interpolation/tree/0fc1dd73ea

which is licensed under MIT. The original license will follow.

---------

Copyright (c) 2013, Nikita Volkov

Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the "Software"), to deal in the Software without
restriction, including without limitation the rights to use,
copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following
conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.

-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}

-- TODO: only export the @i@ quasiquotor when `ghcide` stop type-checking
-- exanded quasiquote splices
module Clash.Util.Interpolate (i, format, toString) where

import           Language.Haskell.Meta.Parse (parseExp)
import           Language.Haskell.TH.Lib     (appE, varE)
import           Language.Haskell.TH.Quote   (QuasiQuoter(..))
import           Language.Haskell.TH.Syntax  (Q, Exp)

import qualified Numeric                as N
import           Data.Char
  (isHexDigit, chr, isOctDigit, isDigit, isSpace)
import           Data.Maybe             (fromMaybe, isJust, catMaybes)
import           Text.Read              (readMaybe)

data Line
  = EmptyLine
  | ExprLine Indent String
  | Line Indent [Node]
  deriving (Int -> Line -> ShowS
[Line] -> ShowS
Line -> String
(Int -> Line -> ShowS)
-> (Line -> String) -> ([Line] -> ShowS) -> Show Line
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Line] -> ShowS
$cshowList :: [Line] -> ShowS
show :: Line -> String
$cshow :: Line -> String
showsPrec :: Int -> Line -> ShowS
$cshowsPrec :: Int -> Line -> ShowS
Show)

data Node
  = Literal String
  | Expression String
  deriving (Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
Show)

type Indent = Int

format :: [Node] -> String
format :: [Node] -> String
format = ShowS
stripWhiteSpace ShowS -> ([Node] -> String) -> [Node] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line] -> String
showLines ([Line] -> String) -> ([Node] -> [Line]) -> [Node] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Line]
nodesToLines
 where
  go :: Int -> ShowS
go Int
_ [] = []
  go Int
n (Char
c:String
cs) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' = Int -> ShowS
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
cs
  go Int
0 (Char
c:String
cs) = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> ShowS
go Int
0 String
cs
  go Int
n String
cs = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> ShowS
go Int
0 String
cs)

  stripWhiteSpace :: ShowS
stripWhiteSpace = Int -> ShowS
go Int
0 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace


showLines :: [Line] -> String
showLines :: [Line] -> String
showLines [] = String
""
showLines [Line]
ns = ShowS
forall a. [a] -> [a]
init ((Line -> String) -> [Line] -> String
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Line -> String
showLine [Line]
ns)
 where
  showLine :: Line -> String
  showLine :: Line -> String
showLine Line
EmptyLine = String
"\n"
  showLine (Line Int
n [Node]
ns') =
    let theIndent :: String
theIndent = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
commonIndent) Char
' ' in
    String
theIndent String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Node -> String) -> [Node] -> String
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Node -> String
nodeToString [Node]
ns') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
  showLine (ExprLine Int
n String
s) =
    let theIndent :: String
theIndent = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
commonIndent) Char
' ' in
    [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
theIndent String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" | String
l <- String -> [String]
lines String
s]

  nodeToString :: Node -> String
  nodeToString :: Node -> String
nodeToString (Literal String
s) = String
s
  nodeToString (Expression String
s) = String
s

  commonIndent :: Indent
  commonIndent :: Int
commonIndent = (Int -> Int -> Int) -> [Int] -> Int
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldl1 Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ((Line -> Maybe Int) -> [Line] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Maybe Int
indent [Line]
ns))

  indent :: Line -> Maybe Indent
  indent :: Line -> Maybe Int
indent Line
EmptyLine = Maybe Int
forall a. Maybe a
Nothing
  indent (ExprLine Int
n String
_) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
  indent (Line Int
n [Node]
_) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n

-- | Collects nodes into lines. Expressions might still contain newlines! Does
-- not start or end with 'EmptyLine'.
nodesToLines :: [Node] -> [Line]
nodesToLines :: [Node] -> [Line]
nodesToLines =
    (Line -> [Line]) -> [Line] -> [Line]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Line -> [Line]
splitLines
  ([Line] -> [Line]) -> ([Node] -> [Line]) -> [Node] -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line] -> [Line]
mergeLines
  ([Line] -> [Line]) -> ([Node] -> [Line]) -> [Node] -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line] -> [Line]
dropEmpty
  ([Line] -> [Line]) -> ([Node] -> [Line]) -> [Node] -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> Line) -> [Line] -> [Line]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Line
splitWords
  ([Line] -> [Line]) -> ([Node] -> [Line]) -> [Node] -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Node] -> Line) -> [[Node]] -> [Line]
forall a b. (a -> b) -> [a] -> [b]
map [Node] -> Line
toLine
  ([[Node]] -> [Line]) -> ([Node] -> [[Node]]) -> [Node] -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Node] -> [Node]) -> [[Node]] -> [[Node]]
forall a b. (a -> b) -> [a] -> [b]
map [Node] -> [Node]
dropTrailingEmpty
  ([[Node]] -> [[Node]])
-> ([Node] -> [[Node]]) -> [Node] -> [[Node]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Node] -> [[Node]]
collectLines []
  ([Node] -> [[Node]]) -> ([Node] -> [Node]) -> [Node] -> [[Node]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Node]
joinLiterals
 where
  emptyLit :: Node -> Maybe Int
emptyLit (Literal String
s) =
    if (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s then
      Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length String
s)
    else
      Maybe Int
forall a. Maybe a
Nothing
  emptyLit Node
_ = Maybe Int
forall a. Maybe a
Nothing

  isEmptyLine :: Line -> Bool
isEmptyLine Line
EmptyLine = Bool
True
  isEmptyLine Line
_ = Bool
False

  dropEmpty :: [Line] -> [Line]
dropEmpty = [Line] -> [Line]
forall a. [a] -> [a]
reverse ([Line] -> [Line]) -> ([Line] -> [Line]) -> [Line] -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> Bool) -> [Line] -> [Line]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Line -> Bool
isEmptyLine ([Line] -> [Line]) -> ([Line] -> [Line]) -> [Line] -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line] -> [Line]
forall a. [a] -> [a]
reverse ([Line] -> [Line]) -> ([Line] -> [Line]) -> [Line] -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> Bool) -> [Line] -> [Line]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Line -> Bool
isEmptyLine
  dropTrailingEmpty :: [Node] -> [Node]
dropTrailingEmpty = [Node] -> [Node]
forall a. [a] -> [a]
reverse ([Node] -> [Node]) -> ([Node] -> [Node]) -> [Node] -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> (Node -> Maybe Int) -> Node -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Maybe Int
emptyLit) ([Node] -> [Node]) -> ([Node] -> [Node]) -> [Node] -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Node]
forall a. [a] -> [a]
reverse

  splitLines :: Line -> [Line]
  splitLines :: Line -> [Line]
splitLines Line
EmptyLine = [Line
EmptyLine]
  splitLines e :: Line
e@(ExprLine {}) = [Line
e]
  splitLines (Line Int
n [Node]
nodes) = ([Node] -> Line) -> [[Node]] -> [Line]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Node] -> Line
Line Int
n) (Int -> [Node] -> [Node] -> [[Node]]
go Int
0 [] [Node]
nodes)
   where
    maxLength :: Int
maxLength = Int
80

    go :: Int -> [Node] -> [Node] -> [[Node]]
    go :: Int -> [Node] -> [Node] -> [[Node]]
go Int
accLen [Node]
acc [Node]
goNodes | Int
accLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLength = [Node] -> [Node]
forall a. [a] -> [a]
reverse [Node]
acc [Node] -> [[Node]] -> [[Node]]
forall a. a -> [a] -> [a]
: Int -> [Node] -> [Node] -> [[Node]]
go Int
0 [] [Node]
goNodes
    go Int
accLen [Node]
acc (l :: Node
l@(Literal String
s):[Node]
goNodes) = Int -> [Node] -> [Node] -> [[Node]]
go (Int
accLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length String
s) (Node
lNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
acc) [Node]
goNodes
    go Int
accLen [Node]
acc (e :: Node
e@(Expression String
s):[Node]
goNodes) = Int -> [Node] -> [Node] -> [[Node]]
go (Int
accLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length String
s) (Node
eNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
acc) [Node]
goNodes
    go Int
_accLen [Node]
acc [] = [[Node] -> [Node]
forall a. [a] -> [a]
reverse [Node]
acc]

  mergeLines :: [Line] -> [Line]
  mergeLines :: [Line] -> [Line]
mergeLines (l0 :: Line
l0@(Line Int
n0 [Node]
nodes0):l1 :: Line
l1@(Line Int
n1 [Node]
nodes1):[Line]
ls) =
    if Int
n0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n1 then
      [Line] -> [Line]
mergeLines (Int -> [Node] -> Line
Line Int
n0 ([Node]
nodes0 [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [String -> Node
Literal String
" "] [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [Node]
nodes1) Line -> [Line] -> [Line]
forall a. a -> [a] -> [a]
: [Line]
ls)
    else
      Line
l0Line -> [Line] -> [Line]
forall a. a -> [a] -> [a]
:[Line] -> [Line]
mergeLines (Line
l1Line -> [Line] -> [Line]
forall a. a -> [a] -> [a]
:[Line]
ls)
  mergeLines (Line
l:[Line]
ls) = Line
lLine -> [Line] -> [Line]
forall a. a -> [a] -> [a]
:[Line] -> [Line]
mergeLines [Line]
ls
  mergeLines [] = []

  splitWords :: Line -> Line
  splitWords :: Line -> Line
splitWords Line
EmptyLine = Line
EmptyLine
  splitWords e :: Line
e@(ExprLine {})= Line
e
  splitWords (Line Int
n [Node]
nodes) = Int -> [Node] -> Line
Line Int
n ((Node -> [Node]) -> [Node] -> [Node]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Node -> [Node]
go [Node]
nodes)
   where
    go :: Node -> [Node]
go (Expression String
s) = [String -> Node
Expression String
s]
    go (Literal String
"") = []
    go (Literal String
s0) =
      let
        pre :: String
pre = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ')) String
s0
        post :: String
post = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')) String
s0
      in case String
post of
        [] -> [String -> Node
Literal String
s0]
        (Char
_:String
s1) -> String -> Node
Literal (String
pre String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ") Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: Node -> [Node]
go (String -> Node
Literal String
s1)

  -- Convert to 'Line' type
  toLine :: [Node] -> Line
toLine = \case
    [] -> Line
EmptyLine
    [Node -> Maybe Int
emptyLit -> Just Int
_] -> Line
EmptyLine
    [Expression String
s] -> Int -> String -> Line
ExprLine Int
0 String
s
    [Node -> Maybe Int
emptyLit -> Just Int
n, Expression String
s] -> Int -> String -> Line
ExprLine Int
n String
s
    ns :: [Node]
ns@(Expression String
_:[Node]
_) -> Int -> [Node] -> Line
Line Int
0 [Node]
ns
    (Literal String
s:[Node]
ns) ->
      Int -> [Node] -> Line
Line
        (String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') String
s))
        (String -> Node
Literal ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') String
s)Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
ns)

  -- collects list of nodes, where each list is a single line
  collectLines :: [Node] -> [Node] -> [[Node]]
collectLines [Node]
collected [Node]
todo =
    case ([Node]
collected, [Node]
todo) of
      ([], []) -> []
      ([Node]
_, []) -> [[Node] -> [Node]
forall a. [a] -> [a]
reverse [Node]
collected]
      ([Node]
_, s :: Node
s@(Expression String
_):[Node]
ns) ->
        [Node] -> [Node] -> [[Node]]
collectLines (Node
sNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
collected) [Node]
ns
      ([Node]
_, Literal String
s0:[Node]
ns) ->
        let
          pre :: String
pre = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
s0
          post :: String
post = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
s0
        in case String
post of
          [] ->
            [Node] -> [Node] -> [[Node]]
collectLines (String -> Node
Literal String
s0Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
collected) [Node]
ns
          (Char
_:String
s1) ->
            [Node] -> [Node]
forall a. [a] -> [a]
reverse (String -> Node
Literal String
preNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
collected) [Node] -> [[Node]] -> [[Node]]
forall a. a -> [a] -> [a]
: [Node] -> [Node] -> [[Node]]
collectLines [] (String -> Node
Literal String
s1Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
ns)

  joinLiterals :: [Node] -> [Node]
  joinLiterals :: [Node] -> [Node]
joinLiterals [] = []
  joinLiterals (Literal String
s0:Literal String
s1:[Node]
ss) = [Node] -> [Node]
joinLiterals (String -> Node
Literal (String
s0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s1)Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
ss)
  joinLiterals (Node
n:[Node]
ns) = Node
nNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node] -> [Node]
joinLiterals [Node]
ns

i :: QuasiQuoter
i :: QuasiQuoter
i = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter {
    quoteExp :: String -> Q Exp
quoteExp = (Name -> Q Exp
varE 'format Q Exp -> Q Exp -> Q Exp
`appE`) (Q Exp -> Q Exp) -> (String -> Q Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> Q Exp
toExp ([Node] -> Q Exp) -> (String -> [Node]) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Node]
parseNodes (String -> [Node]) -> ShowS -> String -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
decodeNewlines
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. String -> a
err String
"pattern"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. String -> a
err String
"type"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. String -> a
err String
"declaration"
  }
  where
    err :: String -> a
err String
name =
      String -> a
forall a. HasCallStack => String -> a
error (String
"Clash.Util.Interpolate.i: This QuasiQuoter can not be used as a "
           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"!")

    toExp:: [Node] -> Q Exp
    toExp :: [Node] -> Q Exp
toExp [Node]
nodes = case [Node]
nodes of
      [] -> [|[]|]
      (Node
x:[Node]
xs) -> Node -> Q Exp
f Node
x Q Exp -> Q Exp -> Q Exp
`appE` [Node] -> Q Exp
toExp [Node]
xs
      where
        f :: Node -> Q Exp
f (Literal String
s) = [|(Literal s:)|]
        f (Expression String
e) = [|(Expression (toString ($(reifyExpression e))):)|]

        reifyExpression :: String -> Q Exp
        reifyExpression :: String -> Q Exp
reifyExpression String
s = case String -> Either String Exp
parseExp String
s of
          Left String
_ -> do
            String -> Q Exp
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Parse error in expression: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s) :: Q Exp
          Right Exp
e -> Exp -> Q Exp
forall (m :: Type -> Type) a. Monad m => a -> m a
return Exp
e

parseNodes :: String -> [Node]
parseNodes :: String -> [Node]
parseNodes = String -> String -> [Node]
go String
""
  where
    go :: String -> String -> [Node]
    go :: String -> String -> [Node]
go String
acc String
input = case String
input of
      String
""  -> [(String -> Node
lit (String -> Node) -> ShowS -> String -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse) String
acc]
      Char
'\\':Char
x:String
xs -> String -> String -> [Node]
go (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc) String
xs
      Char
'#':Char
'{':String
xs -> String -> String -> String -> String -> [Node]
goExpr String
input String
acc [] String
xs
      Char
x:String
xs -> String -> String -> [Node]
go (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) String
xs
    -- allow '}' to be escaped in code sections
    goExpr :: String -> String -> String -> String -> [Node]
goExpr String
input String
accLit String
accExpr String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\') String
xs of
      (String
ys, Char
'}' :String
zs) -> (String -> Node
lit (String -> Node) -> ShowS -> String -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse) String
accLit Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: String -> Node
Expression (ShowS
forall a. [a] -> [a]
reverse String
accExpr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ys) Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: String -> String -> [Node]
go String
"" String
zs
      (String
ys, Char
'\\':Char
'}':String
zs) -> String -> String -> String -> String -> [Node]
goExpr String
input String
accLit (Char
'}' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
forall a. [a] -> [a]
reverse String
ys String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
accExpr) String
zs
      (String
ys, Char
'\\':String
zs) -> String -> String -> String -> String -> [Node]
goExpr String
input String
accLit (Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
forall a. [a] -> [a]
reverse String
ys String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
accExpr) String
zs
      (String
_, String
"") -> [String -> Node
lit (ShowS
forall a. [a] -> [a]
reverse String
accLit String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
input)]
      (String, String)
_ -> String -> [Node]
forall a. HasCallStack => String -> a
error String
"(impossible) parseError in parseNodes"
    lit :: String -> Node
    lit :: String -> Node
lit = String -> Node
Literal (String -> Node) -> ShowS -> String -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
unescape

-------------------------------------------------------------------
-- Everything below this line is unchanged from neat-interpolate --
-------------------------------------------------------------------
decodeNewlines :: String -> String
decodeNewlines :: ShowS
decodeNewlines = ShowS
go
  where
    go :: ShowS
go String
xs = case String
xs of
      Char
'\r' : Char
'\n' : String
ys -> Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
ys
      Char
y : String
ys -> Char
y Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
ys
      [] -> []

toString :: Show a => a -> String
toString :: a -> String
toString a
a = let s :: String
s = a -> String
forall a. Show a => a -> String
show a
a in String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
s (String -> Maybe String
forall a. Read a => String -> Maybe a
readMaybe String
s)
{-# NOINLINE toString #-}
{-# RULES "toString/String" toString = id #-}
{-# RULES "toString/Int" toString = show :: Int -> String #-}
{-# RULES "toString/Integer" toString = show :: Integer -> String #-}
{-# RULES "toString/Float" toString = show :: Float -> String #-}
{-# RULES "toString/Double" toString = show :: Double -> String #-}

-- Haskell 2010 character unescaping, see:
-- http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6
unescape :: String -> String
unescape :: ShowS
unescape = ShowS
go
  where
    go :: ShowS
go String
input = case String
input of
      String
"" -> String
""
      Char
'\\' : Char
'x' : Char
x : String
xs | Char -> Bool
isHexDigit Char
x -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
xs of
        (String
ys, String
zs) -> (Int -> Char
chr (Int -> Char) -> (String -> Int) -> String -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
readHex (String -> Char) -> String -> Char
forall a b. (a -> b) -> a -> b
$ Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
ys) Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
zs
      Char
'\\' : Char
'o' : Char
x : String
xs | Char -> Bool
isOctDigit Char
x -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isOctDigit String
xs of
        (String
ys, String
zs) -> (Int -> Char
chr (Int -> Char) -> (String -> Int) -> String -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
readOct (String -> Char) -> String -> Char
forall a b. (a -> b) -> a -> b
$ Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
ys) Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
zs
      Char
'\\' : Char
x : String
xs | Char -> Bool
isDigit Char
x -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
xs of
        (String
ys, String
zs) -> (Int -> Char
chr (Int -> Char) -> (String -> Int) -> String -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read (String -> Char) -> String -> Char
forall a b. (a -> b) -> a -> b
$ Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
ys) Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
zs
      Char
'\\' : String
input_ -> case String
input_ of
        Char
'\\' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'a' : String
xs -> Char
'\a' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'b' : String
xs -> Char
'\b' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'f' : String
xs -> Char
'\f' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'n' : String
xs -> Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'r' : String
xs -> Char
'\r' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
't' : String
xs -> Char
'\t' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'v' : String
xs -> Char
'\v' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'&' : String
xs -> ShowS
go String
xs
        Char
'N':Char
'U':Char
'L' : String
xs -> Char
'\NUL' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'S':Char
'O':Char
'H' : String
xs -> Char
'\SOH' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'S':Char
'T':Char
'X' : String
xs -> Char
'\STX' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'E':Char
'T':Char
'X' : String
xs -> Char
'\ETX' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'E':Char
'O':Char
'T' : String
xs -> Char
'\EOT' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'E':Char
'N':Char
'Q' : String
xs -> Char
'\ENQ' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'A':Char
'C':Char
'K' : String
xs -> Char
'\ACK' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'B':Char
'E':Char
'L' : String
xs -> Char
'\BEL' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'B':Char
'S' : String
xs -> Char
'\BS' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'H':Char
'T' : String
xs -> Char
'\HT' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'L':Char
'F' : String
xs -> Char
'\LF' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'V':Char
'T' : String
xs -> Char
'\VT' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'F':Char
'F' : String
xs -> Char
'\FF' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'C':Char
'R' : String
xs -> Char
'\CR' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'S':Char
'O' : String
xs -> Char
'\SO' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'S':Char
'I' : String
xs -> Char
'\SI' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'D':Char
'L':Char
'E' : String
xs -> Char
'\DLE' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'D':Char
'C':Char
'1' : String
xs -> Char
'\DC1' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'D':Char
'C':Char
'2' : String
xs -> Char
'\DC2' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'D':Char
'C':Char
'3' : String
xs -> Char
'\DC3' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'D':Char
'C':Char
'4' : String
xs -> Char
'\DC4' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'N':Char
'A':Char
'K' : String
xs -> Char
'\NAK' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'S':Char
'Y':Char
'N' : String
xs -> Char
'\SYN' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'E':Char
'T':Char
'B' : String
xs -> Char
'\ETB' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'C':Char
'A':Char
'N' : String
xs -> Char
'\CAN' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'E':Char
'M' : String
xs -> Char
'\EM' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'S':Char
'U':Char
'B' : String
xs -> Char
'\SUB' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'E':Char
'S':Char
'C' : String
xs -> Char
'\ESC' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'F':Char
'S' : String
xs -> Char
'\FS' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'G':Char
'S' : String
xs -> Char
'\GS' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'R':Char
'S' : String
xs -> Char
'\RS' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'U':Char
'S' : String
xs -> Char
'\US' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'S':Char
'P' : String
xs -> Char
'\SP' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'D':Char
'E':Char
'L' : String
xs -> Char
'\DEL' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'@' : String
xs -> Char
'\^@' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'A' : String
xs -> Char
'\^A' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'B' : String
xs -> Char
'\^B' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'C' : String
xs -> Char
'\^C' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'D' : String
xs -> Char
'\^D' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'E' : String
xs -> Char
'\^E' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'F' : String
xs -> Char
'\^F' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'G' : String
xs -> Char
'\^G' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'H' : String
xs -> Char
'\^H' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'I' : String
xs -> Char
'\^I' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'J' : String
xs -> Char
'\^J' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'K' : String
xs -> Char
'\^K' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'L' : String
xs -> Char
'\^L' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'M' : String
xs -> Char
'\^M' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'N' : String
xs -> Char
'\^N' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'O' : String
xs -> Char
'\^O' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'P' : String
xs -> Char
'\^P' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'Q' : String
xs -> Char
'\^Q' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'R' : String
xs -> Char
'\^R' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'S' : String
xs -> Char
'\^S' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'T' : String
xs -> Char
'\^T' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'U' : String
xs -> Char
'\^U' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'V' : String
xs -> Char
'\^V' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'W' : String
xs -> Char
'\^W' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'X' : String
xs -> Char
'\^X' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'Y' : String
xs -> Char
'\^Y' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'Z' : String
xs -> Char
'\^Z' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'[' : String
xs -> Char
'\^[' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'\\' : String
xs -> Char
'\^\' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
']' : String
xs -> Char
'\^]' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'^' : String
xs -> Char
'\^^' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        Char
'^':Char
'_' : String
xs -> Char
'\^_' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        String
xs -> ShowS
go String
xs
      Char
x:String
xs -> Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs

    readHex :: String -> Int
    readHex :: String -> Int
readHex String
xs = case ReadS Int
forall a. (Eq a, Num a) => ReadS a
N.readHex String
xs of
      [(Int
n, String
"")] -> Int
n
      [(Int, String)]
_ -> String -> Int
forall a. HasCallStack => String -> a
error String
"Data.String.Interpolate.Util.readHex: no parse"

    readOct :: String -> Int
    readOct :: String -> Int
readOct String
xs = case ReadS Int
forall a. (Eq a, Num a) => ReadS a
N.readOct String
xs of
      [(Int
n, String
"")] -> Int
n
      [(Int, String)]
_ -> String -> Int
forall a. HasCallStack => String -> a
error String
"Data.String.Interpolate.Util.readHex: no parse"