content: {-# LANGUAGE TemplateHaskell #-}
  module Lambda.TH
    ( progConst
    , prog
    ) where
  
  import Data.List (sort)
  import Data.Char
  import Data.Data
  import Data.Maybe
  import Text.Megaparsec
  import NeatInterpolation
  
  import qualified Lambda.Parse as P
  import qualified Data.Text as T
  
  import Language.Haskell.TH
  import Language.Haskell.TH.Syntax
  import Language.Haskell.TH.Quote
  
  prog :: QuasiQuoter
  prog = text { quoteExp = applyParseProg . quoteExp text }
  
  applyParseProg :: Q Exp -> Q Exp
  applyParseProg q = appE [|P.parseProg|] q
  
  liftText :: T.Text -> Q Exp
  liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt)
  
  liftDataWithText :: Data a => a -> Q Exp
  liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)
  
  -- NOTE: does not support metavariables
  
  progConst :: QuasiQuoter
  progConst = QuasiQuoter
    { quoteExp = \input -> do
        let src = T.pack $ normalizeQQInput input
        case P.parseLambda "" src of
          Left  e -> fail $ errorBundlePretty e
          Right p -> liftDataWithText p
    , quotePat  = undefined
    , quoteType = undefined
    , quoteDec  = undefined
    }
  
  --
  -- NOTE: copy-paste utility from NeatInterpolation.String hidden module
  --
  normalizeQQInput :: [Char] -> [Char]
  normalizeQQInput = trim . unindent' . tabsToSpaces
    where
      unindent' :: [Char] -> [Char]
      unindent' s =
        case lines s of
          head:tail ->
            let
              unindentedHead = dropWhile (== ' ') head
              minimumTailIndent = minimumIndent . unlines $ tail
              unindentedTail = case minimumTailIndent of
                Just indent -> map (drop indent) tail
                Nothing -> tail
            in unlines $ unindentedHead : unindentedTail
          [] -> []
  
  trim :: [Char] -> [Char]
  trim = dropWhileRev isSpace . dropWhile isSpace
  
  dropWhileRev :: (a -> Bool) -> [a] -> [a]
  dropWhileRev p = foldr (\x xs -> if p x && null xs then [] else x:xs) []
  
  unindent :: [Char] -> [Char]
  unindent s =
    case minimumIndent s of
      Just indent -> unlines . map (drop indent) . lines $ s
      Nothing -> s
  
  tabsToSpaces :: [Char] -> [Char]
  tabsToSpaces ('\t':tail) = "    " ++ tabsToSpaces tail
  tabsToSpaces (head:tail) = head : tabsToSpaces tail
  tabsToSpaces [] = []
  
  minimumIndent :: [Char] -> Maybe Int
  minimumIndent =
    listToMaybe . sort . map lineIndent
      . filter (not . null . dropWhile isSpace) . lines
  
  -- | Amount of preceding spaces on first line
  lineIndent :: [Char] -> Int
  lineIndent = length . takeWhile (== ' ')
  