{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE OrPatterns #-}
module Gyehoek.Sexp
  ( let_
  , sexp
  , nonempty
  , nonEmptyGrammar
  , encode
  , decode
  , parseSexps
  , prefixSugar
  , todo
  , isoIso
  , encodeWith
  , decodeWith
  , kappa
  , lambda
  , kappaKeyword
  , lambdaKeyword
  , encodePrettyWith
  , encodePretty
  , UglySexpIso(..)
  , AsSexpIso(..)
  , SpliceSexp(..)
  , parseSexpsWithPos
  , parseSexpWithPos
  , parseSexp
  , sx
  , sxs
  , makeSx
  , makeSxs
  , makeSx'
  , toSexp
  , fromSexp
  , stripLocation
  , format
  , equivalent
  , encodeOrShow
  )
  where

import Data.Text (Text)
import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
import Language.SexpGrammar qualified as Sexp
import Language.Sexp qualified as S
import Language.SexpGrammar.Generic
import Data.InvertibleGrammar.Base qualified as IGB
import Data.InvertibleGrammar qualified as IG
import Data.InvertibleGrammar.Base ((:-)((:-)))
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.List (List, groupBy)
import Data.Text.Encoding
import Data.Either (either)
import GHC.Generics (Generic)
import Control.Lens hiding (para)
import Data.Generics.Labels
import System.Process
import GHC.IO.Unsafe (unsafePerformIO)
import qualified Data.Text.IO as TIO
import Control.Monad (join)
import qualified Language.Sexp.Located as SL
import Data.Void (absurd, Void)
import Data.Coerce (coerce)
import qualified Data.Map
import Language.Haskell.TH.Quote
import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE, Q, Code, unTypeCode)
import qualified Data.Text as T
import qualified Control.Category
import Data.Data (Data (..), Typeable, cast)
import Language.Haskell.TH.Syntax (lift, Lift, liftData)
import GHC.IsList (fromList)
import Data.Functor.Foldable (cata, para, embed)
import Data.Functor.Classes (Show1(..))
import Data.Vector (Vector)
import Numeric.Natural (Natural)
import Data.Maybe (fromMaybe)
import Control.Applicative (Alternative((<|>)))
import Debug.Pretty.Simple
import qualified Data.Vector as V
import qualified Data.Vector.Strict
import Data.Function (on)
import Data.String (IsString (fromString))


sexp :: SexpIso a => Iso' a Text
sexp = iso
  (either error id . encode)
  (either error id . decode)

format :: Sexp -> Text
format = decodeUtf8 . view strict . SL.format

encode :: SexpIso a => a -> Either String Text
encode = encodeWith sexpIso

decode :: SexpIso a => Text -> Either String a
decode = decodeWith sexpIso

encodeWith :: SexpGrammar a -> a -> Either String Text
encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g

encodePretty :: SexpIso a => a -> Either String Text
encodePretty = encodePrettyWith sexpIso

decodeWith :: SexpGrammar a -> Text -> Either String a
decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8

encodePrettyWith :: SexpGrammar a -> a -> Either String Text
encodePrettyWith g =
  (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g

parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso)

parseSexp :: SexpIso a => FilePath -> Text -> Either String a
parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
  where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)

readSexpWithPos :: Position -> Text -> Either String Sexp
readSexpWithPos pos = SL.parseSexpWithPos pos . view lazy . encodeUtf8

readSexpsWithPos :: Position -> Text -> Either String (List Sexp)
readSexpsWithPos pos = SL.parseSexpsWithPos pos . view lazy . encodeUtf8

parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
parseSexpsWithPos g pos =
  marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)

parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
parseSexpWithPos g pos =
  marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
  where marshal = join . traverseOf _Right (Sexp.fromSexp g)

nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
nonEmptyGrammar = IGB.Iso
  (\((x:|xs) :- t) -> reverse xs :- x :- t)
  (\(xs :- x :- t) -> (x :| reverse xs) :- t)

nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
nonempty a =
  list (el a >>> rest a) >>>
    IG.flipped nonEmptyGrammar

let_
  :: Text
  -> (forall t. Grammar Position (Sexp :- t) (a :- t))
  -> (forall t. Grammar Position (Sexp :- t) (b :- t))
  -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
  -> Grammar Position (Sexp :- t1) t2
let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
  where
    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
    bindings = nonempty binding
    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
    binding = list (el name >>> el rhs) >>> pair

data DotList a = MkDotList (NonEmpty a) a
  deriving (Show, Generic)

dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
dotlist x = list $ rest $ coproduct
  [ x >>> _
  ]

-- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
prefixSugar
  :: Text -> Prefix
  -> Grammar Position (Sexp :- t') a
  -> Grammar Position (Sexp :- t') a
prefixSugar name prefix e = coproduct
  -- 'something
  [ Sexp.prefixed prefix e
  -- (quote something)
  , list $ el (sym name) >>> el e
  ]

todo :: Grammar p (Sexp :- t) t'
todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
  where
    f _ = Left $ unexpected "todo"
    g _ = Left $ unexpected "todo"

kappa
  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
  -> Grammar Position (Sexp :- List a :- t1) t2
  -> Grammar Position (Sexp :- t1) t2
kappa name e = list $
  el kappaKeyword
  >>> el (list $ rest name)
  >>> el e

lambda
  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
  -> Grammar Position (Sexp :- List a :- t1) t2
  -> Grammar Position (Sexp :- t1) t2
lambda name e = list $
  el lambdaKeyword
  >>> el (list $ rest name)
  >>> el e

isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
isoIso l = Sexp.iso (view l) (review l)

kappaKeyword :: Grammar Position (Sexp :- t) t
kappaKeyword = coproduct [ sym "κ", sym "kappa" ]

lambdaKeyword :: Grammar Position (Sexp :- t) t
lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]



class UglySexpIso a where
  uglySexpIso :: SexpGrammar a

newtype AsSexpIso a = AsSexpIso a
newtype AsUglySexpIso a = AsUglySexpIso a

asSexpIso :: Grammar p (a :- t) (AsSexpIso a :- t)
asSexpIso = Sexp.iso AsSexpIso (\(AsSexpIso x) -> x)

instance UglySexpIso a => SexpIso (AsUglySexpIso a) where
  sexpIso = uglySexpIso @a >>> Sexp.iso coerce coerce

instance SexpIso a => UglySexpIso (AsSexpIso a) where
  uglySexpIso = sexpIso >>> Sexp.iso (\x -> AsSexpIso x) (\(AsSexpIso x) -> x)

-- why not work
-- deriving via AsSexpIso Text instance UglySexpIso Text

instance UglySexpIso Text where uglySexpIso = sexpIso
instance UglySexpIso Integer where uglySexpIso = sexpIso
instance UglySexpIso Int where uglySexpIso = sexpIso
instance UglySexpIso Bool where uglySexpIso = sexpIso
instance UglySexpIso Double where uglySexpIso = sexpIso
instance UglySexpIso () where uglySexpIso = sexpIso

instance SexpIso Sexp where
  sexpIso = Control.Category.id

-- evil ass orphan instances
deriving instance (Data a, Data e) => Data (SL.LocatedBy a e)
deriving instance Data SL.Atom
deriving instance Data SL.Prefix
deriving instance Data SL.Position
deriving instance (Data e) => Data (SL.SexpF e)


-- Quasiquoter

getPos = do
  Loc {loc_filename,loc_start} <- location
  pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)

fromSexp :: SexpIso a => Sexp -> a
fromSexp = either error id . Sexp.fromSexp sexpIso

fromSexp' :: SexpGrammar a -> Sexp -> a
fromSexp' g = either error id . Sexp.fromSexp g

toSexp :: SexpIso a => a -> Sexp
toSexp = either error id . Sexp.toSexp sexpIso

toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
toSexps = foldMap \x -> [toSexp x]

pattern Unquote x =
  SL.Modified Hash (SL.BraceList [SL.Symbol x])
pattern UnquoteSplicing x =
  SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))

_UnquoteSplicing :: Prism' Sexp.Sexp Text
_UnquoteSplicing = prism'
  UnquoteSplicing
  (\case { UnquoteSplicing x -> Just x ; _ -> Nothing })

instance Each Sexp Sexp Sexp Sexp where
  each k (SL.ParenList xs)              = SL.ParenList <$> traverse k xs
  each k (SL.BracketList xs)            = SL.BracketList <$> traverse k xs
  each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
  each _ e@(SL.Atom _; SL.Modified _ _) = pure e

stripLocation :: Sexp -> Sexp
stripLocation = cata \case
  SL.Compose (a SL.:< e) ->
    SL.Fix . SL.Compose $ SL.dummyPos SL.:< e

-- | @('==')@ for 'Sexp's modulo source location — return true if the
-- two sexps are equal in all but 'Position' fields.
equivalent :: Sexp -> Sexp -> Bool
equivalent = (==) `on` stripLocation

instance SexpIso Natural where
  sexpIso = Sexp.integer >>> Sexp.partialOsi f g
    where
      f n | n < 0 = Left $ Sexp.unexpected "negative"
                        <> Sexp.expected "natural"
          | otherwise = Right $ fromIntegral n
      g n = fromIntegral n

class SpliceSexp a where
  spliceSexp :: a -> List Sexp

instance SexpIso a => SpliceSexp (Data.Vector.Strict.Vector a) where
  spliceSexp = toSexps

instance SexpIso a => SpliceSexp (Vector a) where
  spliceSexp = toSexps

instance SexpIso a => SpliceSexp (List a) where
  spliceSexp = toSexps

instance SpliceSexp Sexp where
  spliceSexp = toListOf each

unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ
unquoteSplicingRecursive xs = [| mconcat $(spans) |]
  where
    spans = xs
      & groupBy \cases
          (UnquoteSplicing _) _ -> False
          _ (UnquoteSplicing _) -> False
          _ _                   -> True
      & fmap \case
        -- [e@(Unquote _)] ->
        --   case unquote e of
        --     Just x -> [| [$(x)] |]
        --     Nothing -> error "unreachable"
        [UnquoteSplicing x] ->
          [| spliceSexp $(varE (mkName (T.unpack x))) |]
        es -> listE $ unquoteRecursive <$> es
      & listE

unquoteRecursive :: Sexp.Sexp -> ExpQ
unquoteRecursive = \case
  Unquote x -> [| toSexp $(varE (mkName (T.unpack x))) |]
  SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|]
  e -> liftData e

_ParenList :: Prism' Sexp (List Sexp)
_ParenList = prism' SL.ParenList \case
  SL.ParenList xs -> Just xs
  _ -> Nothing

metaSexps :: List Sexp.Sexp -> Maybe ExpQ
metaSexps = Just . unquoteSplicingRecursive

metaSexp :: Sexp.Sexp -> Maybe ExpQ
metaSexp = Just . unquoteRecursive

-- 뻘짓뻘짓뻘짓뻘짓뻘짓
class Lift1 f where
  liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp

lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
lift1 = liftLift lift

instance Lift1 f => Lift (SL.Fix f) where
  lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner)

instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
  liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|]

instance Lift a => Lift1 (SL.LocatedBy a) where
  liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]

instance Lift1 List where
  liftLift l xs = listE $ l <$> xs

instance Lift1 SL.SexpF where
  liftLift l = \case
    SL.AtomF a -> [|SL.AtomF $(lift a)|]
    SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
    SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
    SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
    SL.ModifiedF p e -> [|SL.ModifiedF $(lift p) $(l e)|]

-- deriving instance Lift a => Lift (SL.SexpF a)
deriving instance Lift SL.Atom
deriving instance Lift SL.Position
deriving instance Lift SL.Prefix

encodeOrShow :: (SexpIso a, Show a, IsString s) => a -> s
encodeOrShow a = fromString case encode a of
  Left _ -> show a
  Right e -> T.unpack e

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

makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter
makeSxs f = QuasiQuoter
  { quoteExp = \str -> do
      pos <- getPos
      case readSexpsWithPos pos (T.pack str) of
        Left e -> fail e
        Right xs -> [| $(unTypeCode f) $e |]
          where
            e = dataToExpQ
              (const Nothing `extQ` metaSexp `extQ` metaSexps)
              xs
  , 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
      pos <- getPos
      case readSexpWithPos pos (T.pack str) of
        Left e -> fail e
        Right x -> [| $f $e |]
          where
            e = dataToExpQ
              (const Nothing `extQ` metaSexp `extQ` metaSexps)
              x
  , quotePat = undefined
  , quoteType = undefined
  , quoteDec = undefined
  }

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

sxs = makeSxs [||id||]
sx = makeSx [||id||]