{-|
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 #-}

module Clash.Util.Interpolate(i) 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 _ [] = []
  go n :: Int
n (c :: Char
c:cs :: String
cs) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' = Int -> ShowS
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) String
cs
  go 0 (c :: Char
c:cs :: String
cs) = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> ShowS
go 0 String
cs
  go n :: Int
n cs :: String
cs = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n ' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> ShowS
go 0 String
cs)

  stripWhiteSpace :: ShowS
stripWhiteSpace = Int -> ShowS
go 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 [] = ""
showLines ns :: [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 EmptyLine = "\n"
  showLine (Line n :: Int
n ns' :: [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) ' ' 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]
++ "\n"
  showLine (ExprLine n :: Int
n s :: 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) ' ' 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]
++ "\n" | String
l <- String -> [String]
lines String
s]

  nodeToString :: Node -> String
  nodeToString :: Node -> String
nodeToString (Literal s :: String
s) = String
s
  nodeToString (Expression s :: 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 EmptyLine = Maybe Int
forall a. Maybe a
Nothing
  indent (ExprLine n :: Int
n _) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
  indent (Line n :: Int
n _) = 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 s :: 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 _ = Maybe Int
forall a. Maybe a
Nothing

  isEmptyLine :: Line -> Bool
isEmptyLine EmptyLine = Bool
True
  isEmptyLine _ = 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 EmptyLine = [Line
EmptyLine]
  splitLines e :: Line
e@(ExprLine {}) = [Line
e]
  splitLines (Line n :: Int
n nodes :: [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 0 [] [Node]
nodes)
   where
    maxLength :: Int
maxLength = 80

    go :: Int -> [Node] -> [Node] -> [[Node]]
    go :: Int -> [Node] -> [Node] -> [[Node]]
go accLen :: Int
accLen acc :: [Node]
acc goNodes :: [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 0 [] [Node]
goNodes
    go accLen :: Int
accLen acc :: [Node]
acc (l :: Node
l@(Literal s :: String
s):goNodes :: [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 accLen :: Int
accLen acc :: [Node]
acc (e :: Node
e@(Expression s :: String
s):goNodes :: [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 _accLen :: Int
_accLen acc :: [Node]
acc [] = [[Node] -> [Node]
forall a. [a] -> [a]
reverse [Node]
acc]

  mergeLines :: [Line] -> [Line]
  mergeLines :: [Line] -> [Line]
mergeLines (l0 :: Line
l0@(Line n0 :: Int
n0 nodes0 :: [Node]
nodes0):l1 :: Line
l1@(Line n1 :: Int
n1 nodes1 :: [Node]
nodes1):ls :: [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 " "] [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 (l :: Line
l:ls :: [Line]
ls) = Line
lLine -> [Line] -> [Line]
forall a. a -> [a] -> [a]
:[Line] -> [Line]
mergeLines [Line]
ls
  mergeLines [] = []

  splitWords :: Line -> Line
  splitWords :: Line -> Line
splitWords EmptyLine = Line
EmptyLine
  splitWords e :: Line
e@(ExprLine {})= Line
e
  splitWords (Line n :: Int
n nodes :: [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 s :: String
s) = [String -> Node
Expression String
s]
    go (Literal "") = []
    go (Literal s0 :: 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
==' ')) 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
== ' ')) String
s0
      in case String
post of
        [] -> [String -> Node
Literal String
s0]
        (_:s1 :: String
s1) -> String -> Node
Literal (String
pre String -> ShowS
forall a. [a] -> [a] -> [a]
++ " ") 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 _] -> Line
EmptyLine
    [Expression s :: String
s] -> Int -> String -> Line
ExprLine 0 String
s
    [Node -> Maybe Int
emptyLit -> Just n :: Int
n, Expression s :: String
s] -> Int -> String -> Line
ExprLine Int
n String
s
    ns :: [Node]
ns@(Expression _:_) -> Int -> [Node] -> Line
Line 0 [Node]
ns
    (Literal s :: String
s:ns :: [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
==' ') 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
==' ') 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 collected :: [Node]
collected todo :: [Node]
todo =
    case ([Node]
collected, [Node]
todo) of
      ([], []) -> []
      (_, []) -> [[Node] -> [Node]
forall a. [a] -> [a]
reverse [Node]
collected]
      (_, s :: Node
s@(Expression _):ns :: [Node]
ns) ->
        [Node] -> [Node] -> [[Node]]
collectLines (Node
sNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
collected) [Node]
ns
      (_, Literal s0 :: String
s0:ns :: [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
/= '\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
/= '\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
          (_:s1 :: 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 s0 :: String
s0:Literal s1 :: String
s1:ss :: [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 (n :: Node
n:ns :: [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 "pattern"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. String -> a
err "type"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. String -> a
err "declaration"
  }
  where
    err :: String -> a
err name :: String
name =
      String -> a
forall a. HasCallStack => String -> a
error ("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]
++ "!")

    toExp:: [Node] -> Q Exp
    toExp :: [Node] -> Q Exp
toExp nodes :: [Node]
nodes = case [Node]
nodes of
      [] -> [|[]|]
      (x :: Node
x:xs :: [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 s :: String
s) = [|(Literal s:)|]
        f (Expression e :: String
e) = [|(Expression (toString ($(reifyExpression e))):)|]

        reifyExpression :: String -> Q Exp
        reifyExpression :: String -> Q Exp
reifyExpression s :: String
s = case String -> Either String Exp
parseExp String
s of
          Left _ -> do
            String -> Q Exp
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail ("Parse error in expression: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s) :: Q Exp
          Right e :: 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 ""
  where
    go :: String -> String -> [Node]
    go :: String -> String -> [Node]
go acc :: String
acc input :: String
input = case String
input of
      ""  -> [(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]
      '\\':x :: Char
x:xs :: String
xs -> String -> String -> [Node]
go (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc) String
xs
      '#':'{':xs :: String
xs -> String -> String -> String -> String -> [Node]
goExpr String
input String
acc [] String
xs
      x :: Char
x:xs :: 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 input :: String
input accLit :: String
accLit accExpr :: String
accExpr xs :: String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\x :: Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '}' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\\') String
xs of
      (ys :: String
ys, '}' :zs :: 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
zs
      (ys :: String
ys, '\\':'}':zs :: String
zs) -> String -> String -> String -> String -> [Node]
goExpr String
input String
accLit ('}' 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
      (ys :: String
ys, '\\':zs :: String
zs) -> String -> String -> String -> String -> [Node]
goExpr String
input String
accLit ('\\' 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 -> Node
lit (ShowS
forall a. [a] -> [a]
reverse String
accLit String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
input)]
      _ -> String -> [Node]
forall a. HasCallStack => String -> a
error "(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 xs :: String
xs = case String
xs of
      '\r' : '\n' : ys :: String
ys -> '\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
ys
      y :: Char
y : ys :: 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
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 input :: String
input = case String
input of
      "" -> ""
      '\\' : 'x' : x :: Char
x : xs :: 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
        (ys :: String
ys, zs :: 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
      '\\' : 'o' : x :: Char
x : xs :: 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
        (ys :: String
ys, zs :: 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
      '\\' : x :: Char
x : xs :: 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
        (ys :: String
ys, zs :: 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
      '\\' : input_ :: String
input_ -> case String
input_ of
        '\\' : xs :: String
xs -> '\\' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'a' : xs :: String
xs -> '\a' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'b' : xs :: String
xs -> '\b' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'f' : xs :: String
xs -> '\f' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'n' : xs :: String
xs -> '\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'r' : xs :: String
xs -> '\r' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        't' : xs :: String
xs -> '\t' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'v' : xs :: String
xs -> '\v' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '&' : xs :: String
xs -> ShowS
go String
xs
        'N':'U':'L' : xs :: String
xs -> '\NUL' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'S':'O':'H' : xs :: String
xs -> '\SOH' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'S':'T':'X' : xs :: String
xs -> '\STX' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'E':'T':'X' : xs :: String
xs -> '\ETX' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'E':'O':'T' : xs :: String
xs -> '\EOT' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'E':'N':'Q' : xs :: String
xs -> '\ENQ' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'A':'C':'K' : xs :: String
xs -> '\ACK' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'B':'E':'L' : xs :: String
xs -> '\BEL' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'B':'S' : xs :: String
xs -> '\BS' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'H':'T' : xs :: String
xs -> '\HT' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'L':'F' : xs :: String
xs -> '\LF' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'V':'T' : xs :: String
xs -> '\VT' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'F':'F' : xs :: String
xs -> '\FF' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'C':'R' : xs :: String
xs -> '\CR' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'S':'O' : xs :: String
xs -> '\SO' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'S':'I' : xs :: String
xs -> '\SI' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'D':'L':'E' : xs :: String
xs -> '\DLE' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'D':'C':'1' : xs :: String
xs -> '\DC1' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'D':'C':'2' : xs :: String
xs -> '\DC2' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'D':'C':'3' : xs :: String
xs -> '\DC3' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'D':'C':'4' : xs :: String
xs -> '\DC4' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'N':'A':'K' : xs :: String
xs -> '\NAK' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'S':'Y':'N' : xs :: String
xs -> '\SYN' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'E':'T':'B' : xs :: String
xs -> '\ETB' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'C':'A':'N' : xs :: String
xs -> '\CAN' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'E':'M' : xs :: String
xs -> '\EM' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'S':'U':'B' : xs :: String
xs -> '\SUB' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'E':'S':'C' : xs :: String
xs -> '\ESC' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'F':'S' : xs :: String
xs -> '\FS' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'G':'S' : xs :: String
xs -> '\GS' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'R':'S' : xs :: String
xs -> '\RS' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'U':'S' : xs :: String
xs -> '\US' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'S':'P' : xs :: String
xs -> '\SP' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        'D':'E':'L' : xs :: String
xs -> '\DEL' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'@' : xs :: String
xs -> '\^@' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'A' : xs :: String
xs -> '\^A' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'B' : xs :: String
xs -> '\^B' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'C' : xs :: String
xs -> '\^C' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'D' : xs :: String
xs -> '\^D' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'E' : xs :: String
xs -> '\^E' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'F' : xs :: String
xs -> '\^F' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'G' : xs :: String
xs -> '\^G' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'H' : xs :: String
xs -> '\^H' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'I' : xs :: String
xs -> '\^I' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'J' : xs :: String
xs -> '\^J' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'K' : xs :: String
xs -> '\^K' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'L' : xs :: String
xs -> '\^L' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'M' : xs :: String
xs -> '\^M' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'N' : xs :: String
xs -> '\^N' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'O' : xs :: String
xs -> '\^O' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'P' : xs :: String
xs -> '\^P' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'Q' : xs :: String
xs -> '\^Q' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'R' : xs :: String
xs -> '\^R' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'S' : xs :: String
xs -> '\^S' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'T' : xs :: String
xs -> '\^T' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'U' : xs :: String
xs -> '\^U' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'V' : xs :: String
xs -> '\^V' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'W' : xs :: String
xs -> '\^W' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'X' : xs :: String
xs -> '\^X' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'Y' : xs :: String
xs -> '\^Y' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'Z' : xs :: String
xs -> '\^Z' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'[' : xs :: String
xs -> '\^[' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'\\' : xs :: String
xs -> '\^\' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':']' : xs :: String
xs -> '\^]' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'^' : xs :: String
xs -> '\^^' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        '^':'_' : xs :: String
xs -> '\^_' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
        xs :: String
xs -> ShowS
go String
xs
      x :: Char
x:xs :: String
xs -> Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs

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

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