{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}
module Gyehoek.Sexp
  ( let_
  , sexp
  , nonempty
  , nonEmptyGrammar
  , encode
  , decode
  , parseSexps
  )
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


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) -> xs :- x :- t)
  (\(xs :- x :- t) -> (x:|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 >>> _
  ]

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