-- TODO: knock out these warnings
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}

{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternGuards      #-}
{-# LANGUAGE TemplateHaskell    #-}

module HsHere
  ( here
  , lexemeP
  , nestedP
  , parensP
  , bracksP
  , oparenP
  , obrackP
  , cbrackP
  ) where

import qualified Control.Monad.Fail           as Fail
import           Data.Generics                (Data)
import           Language.Haskell.Meta        (parseExp, parsePat)
import           Language.Haskell.Meta.Utils  (cleanNames)
import           Language.Haskell.TH.Lib      hiding (parensP)
import           Language.Haskell.TH.Ppr
import           Language.Haskell.TH.Quote
import           Language.Haskell.TH.Syntax
import           Text.ParserCombinators.ReadP

-- TODO: narrow type & move to shared module
quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a
quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++)

-- TODO: narrow type & move to shared module
quoteDecNotImplemented :: Fail.MonadFail m => String -> m a
quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ )


data Here
  = CodeH Exp
  | TextH String
  | ManyH [Here]
  deriving (Eq,Show,Data)

-- | Example:
--
-- > a x = [here| random "text" $(x + 1)
-- >  something else|]
--
-- Is like:
--
-- > a x = " random \"text\" "++ show (x + 1) ++"\n  something else"
here :: QuasiQuoter
here = QuasiQuoter
        {quoteType = quoteTypeNotImplemented
        ,quoteDec = quoteDecNotImplemented
        ,quoteExp = hereExpQ
        ,quotePat = herePatQ}

instance Lift Here where
  lift (TextH s)  = (litE . stringL) s
  lift (CodeH e)  = [|show $(return e)|]
  lift (ManyH hs) = [|concat $(listE (fmap lift hs))|]

#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped = unsafeCodeCoerce . lift
#elif MIN_VERSION_template_haskell(2,16,0)
  liftTyped = unsafeTExpCoerce . lift -- TODO: the right way?
#endif


hereExpQ :: String -> ExpQ
hereExpQ s = case run s of
              []  -> fail "here: parse error"
              e:_ -> lift (cleanNames e)

herePatQ :: String -> PatQ
herePatQ s = do
  e <- hereExpQ s
  let p = (parsePat
            . pprint
              . cleanNames) e
  case p of
    Left e  -> fail e
    Right p -> return p

run :: String -> [Here]
run = fst . parse

parse :: String -> ([Here], String)
parse = runP hereP

hereP :: ReadP Here
hereP = (ManyH . mergeTexts)
  `fmap` many (oneP =<< look)

mergeTexts :: [Here] -> [Here]
mergeTexts [] = []
mergeTexts (TextH s:TextH t:hs)
  = mergeTexts (TextH (s++t):hs)
mergeTexts (h:hs) = h : mergeTexts hs

oneP :: String -> ReadP Here
oneP s
  | [] <- s         = pfail
  | '\\':'$':s <- s = do skip 2
                         (TextH . ("\\$"++))
                          `fmap` munch (/='\\')
  | '$':'(':s <- s  = skip 2 >> go 1 [] s
  | c:s <- s        = do skip 1
                         (TextH . (c:))
                          `fmap` munch (not.(`elem`"\\$"))
  where go :: Int -> String -> String -> ReadP Here
        go _ acc  []         = return (TextH (reverse acc))
        go 1 []  (')':_) = skip 1 >> return (TextH "$()")
        go 1 acc (')':_) = do skip (1 + length acc)
                              let s = reverse acc
                              either (const (return
                                              (TextH s)))
                                     (return . CodeH)
                                     (parseExp s)
        go n acc ('(':s)     = go (n+1) ('(':acc) s
        go n acc (')':s)     = go (n-1) (')':acc) s
        go n acc (c:s)       = go n (c:acc) s


runP :: ReadP a -> String -> ([a], String)
runP p s = case readP_to_S p s of
              [] -> ([],[])
              xs -> mapfst (:[]) (last xs)
  where mapfst f (a,b) = (f a,b)
skip :: Int -> ReadP ()
skip n = count n get >> return ()
lexemeP :: ReadP a -> ReadP a
lexemeP p = p >>= \x -> skipSpaces >> return x
nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)
nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)
parensP, bracksP :: ReadP a -> ReadP a
parensP  = between oparenP cparenP
bracksP  = between oparenP cparenP
oparenP, cparenP, obrackP, cbrackP :: ReadP Char
oparenP  = char '('
cparenP  = char ')'
obrackP  = char '['
cbrackP  = char ']'