{-# LANGUAGE TemplateHaskell #-}
module Gyehoek.Sexp.QQ
  ( makeSxs
  , makeSx
  , makeSx'
  , sx
  , sxs
  , QuasiQuoter
  ) where

import Data.Data (Typeable, cast)
import Gyehoek.Prelude
import Gyehoek.Sexp.Syntax
import Language.Haskell.TH
import qualified Data.Text as T
import Data.List (groupBy)
import Language.Haskell.TH.Syntax (liftData, Lift (lift))
import Gyehoek.Jalmot
import Gyehoek.Sexp.Grammar
import Control.Exception (throw)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (dataToExpQ)
import qualified Gyehoek.Sexp.Read as Read
import Text.Megaparsec.Pos (mkPos)
import Gyehoek.Lift1
import Data.Foldable (toList)


extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
extQ f g a = maybe (f a) g (cast a)

spliceMeta :: (HasCallStack, DataIso a) => a -> List Datum
spliceMeta x =
  case runPureEff . runJalmot . toData dataIso $ x of
    Left (cs,e) -> throw $ MkAJalmotCS cs e
    Right xs -> xs

meta :: (HasCallStack, DatumIso a) => a -> Datum
meta x =
  case runPureEff . runJalmot . toDatum datumIso $ x of
    Left (cs,e) -> throw $ MkAJalmotCS cs e
    Right xs -> xs

unquoteSplicingRecursive :: List Datum -> ExpQ
unquoteSplicingRecursive xs = [| mconcat $(spans) |]
  where
    spans = xs
      & groupBy \cases
          (MetaSplice _) _ -> False
          _ (MetaSplice _) -> False
          _ _              -> True
      & fmap \case
        [MetaSplice x] ->
          [| spliceMeta $(varE (mkName (T.unpack x))) |]
        es -> listE $ unquoteRecursive <$> es
      & listE

unquoteRecursive :: Datum -> ExpQ
unquoteRecursive = \case
  Meta x -> [| meta $(varE (mkName (T.unpack x))) |]
  a :< CompoundF x -> [| $(liftData a) :< CompoundF $c|]
    where
      c = case x of
        ListF ind xs ->
          [| ListF $(lift ind) $(unquoteSplicingRecursive xs) |]
        VectorF xs ->
          [| VectorF $(unquoteSplicingRecursive xs) |]
        DotListF xs t ->
          [| DotListF $(liftLift unquoteRecursive xs) $(unquoteRecursive t) |]
        AbbrevF p t ->
          [| AbbrevF $(lift p) $(unquoteRecursive t) |]
  e -> liftData e



getPos :: Q SourcePos
getPos = do
  Loc {loc_filename,loc_start} <- location
  pure $ SourcePos
    { sourceName = loc_filename
    , sourceLine = mkPos $ fst loc_start
    , sourceColumn = mkPos $ snd loc_start
    }

readq
  :: (SourcePos -> Text -> Eff '[Jalmot, IOE] a)
  -> String -> Q a
readq f s = do
  pos <- getPos
  liftIO . runJalmotIO . f pos . T.pack $ s

makeSxs :: Data r => Code Q (List Datum -> r) -> QuasiQuoter
makeSxs f = QuasiQuoter
  { quoteExp = \str -> do
      xs <- readq Read.readStringWithPos str
      let e = dataToExpQ
             (const Nothing
              `extQ` (Just . unquoteRecursive)
              `extQ` (Just . unquoteSplicingRecursive))
             xs
      [| $(unTypeCode f) $e |]
  , quotePat = undefined
  , quoteType = undefined
  , quoteDec = undefined
  }

-- | An untyped variant of 'makeSx', useful when the user function is
-- polymorphic in its return value.
makeSx' :: ExpQ -> QuasiQuoter
makeSx' f = QuasiQuoter
  { quoteExp = \str -> do
      x <- readq Read.readStringWithPos1 str
      let e = dataToExpQ
             (const Nothing
              `extQ` (Just . unquoteRecursive)
              `extQ` (Just . unquoteSplicingRecursive))
             x
      [| $f $e |]
  , quotePat = undefined
  , quoteType = undefined
  , quoteDec = undefined
  }

makeSx :: Data r => Code Q (Datum -> r) -> QuasiQuoter
makeSx = makeSx' . unTypeCode

sx, sxs :: QuasiQuoter
sxs = makeSxs [|| Prelude.id @(List Datum) ||]
sx = makeSx [|| Prelude.id @Datum ||]