{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}
module Gyehoek.Sexp
  ( let_
  , sexp
  , nonempty
  , nonEmptyGrammar
  , encode
  , decode
  , parseSexps
  , prefixSugar
  , todo
  )
where

import Data.Text (Text)
import Language.SexpGrammar as Sexp hiding (List, encode, decode, iso)
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 (List)
import Data.Text.Encoding
import Data.Either (either)
import GHC.Generics (Generic)
import Control.Lens
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 SexpLoc
import Data.Void (absurd)


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

encode :: SexpIso a => a -> Either String Text
encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode

decode :: SexpIso a => Text -> Either String a
decode = Sexp.decode . view lazy . encodeUtf8

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

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_
  :: (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_ name rhs e = list (el (sym "let") >>> 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"

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 (sym "lambda")
  >>> el (list $ rest name)
  >>> el e