-- For Viewer
{-# LANGUAGE GADTs #-}
-- For convenience
{-# LANGUAGE OverloadedStrings #-}
-- For Show (SomeData a)
{-# LANGUAGE UndecidableInstances #-}

-- | This module provides the 'Viewer' semantic
-- which interprets combinators as human-readable text.
-- However there is no wrapping nor indenting.
module Symantic.Semantics.Viewer where

import Data.Function qualified as Fun
import Data.Int (Int)
import Data.List qualified as List
import Data.String
import Numeric.Natural (Natural)
import Text.Show
import Prelude qualified

import Symantic.Semantics.Data
import Symantic.Semantics.LetInserter
import Symantic.Semantics.Viewer.Fixity
import Symantic.Syntaxes.Classes
import Symantic.Syntaxes.Derive

-- * Type 'Viewer'
data Viewer a where
  Viewer :: (ViewerEnv -> ShowS) -> Viewer a
  ViewerUnifix :: Unifix -> String -> String -> Viewer (a -> b)
  ViewerInfix :: Infix -> String -> String -> Viewer (a -> b -> c)
  ViewerApp :: Viewer (b -> a) -> Viewer b -> Viewer a

view :: Viewer a -> String
view v =
  runView
    v
    ViewerEnv
      { viewerEnvOp = (infixN 0, SideL)
      , viewerEnvPair = pairParen
      , viewerEnvLamDepth = 1
      }
    ""

runView :: Viewer a -> ViewerEnv -> ShowS
runView (Viewer v) env = v env
runView (ViewerInfix _op name _infixName) _env = showString name
runView (ViewerUnifix _op name _unifixName) _env = showString name
runView (ViewerApp f x) env =
  pairViewer env op Fun.$
    runView f env{viewerEnvOp = (op, SideL)}
      Fun.. showString " "
      Fun.. runView x env{viewerEnvOp = (op, SideR)}
  where
    op = infixL 10

-- | Unusual, but enables to leverage default definition of methods.
type instance Derived Viewer = Viewer

instance LiftDerived Viewer where
  liftDerived = Fun.id

instance IsString (Viewer a) where
  fromString s = Viewer Fun.$ \_env -> showString s
instance Show (Viewer a) where
  showsPrec p v =
    runView
      v
      ViewerEnv
        { viewerEnvOp = (infixN p, SideL)
        , viewerEnvPair = pairParen
        , viewerEnvLamDepth = 1
        }
instance Show (SomeData Viewer a) where
  showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)

-- ** Type 'ViewerEnv'
data ViewerEnv = ViewerEnv
  { viewerEnvOp :: (Infix, Side)
  , viewerEnvPair :: Pair
  , viewerEnvLamDepth :: Natural
  }

pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
pairViewer env op s =
  if isPairNeeded (viewerEnvOp env) op
    then showString o Fun.. s Fun.. showString c
    else s
  where
    (o, c) = viewerEnvPair env

instance Abstractable Viewer where
  lam f = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      let x = showString "x" Fun.. shows (viewerEnvLamDepth env)
      in showString "\\"
          Fun.. x
          Fun.. showString " -> "
          Fun.. runView
            (f (Viewer (\_env -> x)))
            env
              { viewerEnvOp = (op, SideL)
              , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
              }
    where
      op = infixL 1
instance Letable Viewer where
  let_ x f = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      let l = showString "x" Fun.. shows (viewerEnvLamDepth env)
      in showString "let "
          Fun.. l
          Fun.. showString " = "
          Fun.. runView
            x
            env
              { viewerEnvOp = (infixN 0, SideL)
              , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
              }
          Fun.. showString " in "
          Fun.. runView
            (f (Viewer (\_env -> l)))
            env
              { viewerEnvOp = (infixN 0, SideL)
              , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
              }
    where
      op = infixL 1
instance LetRecable Int Viewer where
  letRec len f body = Viewer Fun.$ \env ->
    let fns =
          [ showString "u" Fun.. shows (viewerEnvLamDepth env Prelude.+ Prelude.fromIntegral idx)
          | idx <- [0 .. len Prelude.- 1]
          ]
    in let self idx = Viewer Fun.$ \_env -> fns List.!! idx
       in let lvs = List.zipWith (\v idx -> (v, f self idx)) fns [0 .. len Prelude.- 1]
          in pairViewer env op Fun.$
              showString "letRec "
                Fun.. showListWith
                  ( \(lhs, rhs) ->
                      lhs
                        Fun.. showString " = "
                        Fun.. runView
                          rhs
                          env
                            { viewerEnvOp = (infixN 0, SideL)
                            , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
                            }
                  )
                  lvs
                Fun.. showString " in "
                Fun.. runView
                  (body self)
                  env
                    { viewerEnvOp = (infixN 0, SideL)
                    , viewerEnvLamDepth = viewerEnvLamDepth env Prelude.+ Prelude.fromIntegral len
                    }
    where
      op = infixN 10
instance Abstractable1 Viewer where
  lam1 f = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      let x = showString "u" Fun.. shows (viewerEnvLamDepth env)
      in showString "\\"
          Fun.. x
          Fun.. showString " -> "
          Fun.. runView
            (f (Viewer (\_env -> x)))
            env
              { viewerEnvOp = (op, SideL)
              , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
              }
    where
      op = infixN 0
instance Instantiable Viewer where
  ViewerApp (ViewerInfix op _name infixName) x .@ y = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      runView x env{viewerEnvOp = (op, SideL)}
        Fun.. showString " "
        Fun.. showString infixName
        Fun.. showString " "
        Fun.. runView y env{viewerEnvOp = (op, SideR)}
  f .@ x = ViewerApp f x
instance Unabstractable Viewer where
  ap = ViewerInfix (infixL 4) "(<*>)" "<*>"
  const = "const"
  id = "id"
  (.) = ViewerInfix (infixR 9) "(.)" "."
  flip = flip
  ($) = ViewerInfix (infixR 0) "($)" "$"
instance Varable Viewer where
  var = Fun.id
instance Anythingable Viewer
instance Bottomable Viewer where
  bottom = "<hidden>"
instance Show c => Constantable c Viewer where
  constant c = Viewer Fun.$ \_env -> shows c
instance Eitherable Viewer where
  either = "either"
  left = "Left"
  right = "Right"
instance Equalable Viewer where
  equal = ViewerInfix (infixN 4) "(==)" "=="
instance Listable Viewer where
  cons = ViewerInfix (infixR 5) "(:)" ":"
  nil = "[]"
instance Maybeable Viewer where
  nothing = "Nothing"
  just = "Just"
instance IfThenElseable Viewer where
  ifThenElse test ok ko = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      showString "if "
        Fun.. runView test env{viewerEnvOp = (op, SideL)}
        Fun.. showString " then "
        Fun.. runView ok env{viewerEnvOp = (op, SideL)}
        Fun.. showString " else "
        Fun.. runView ko env{viewerEnvOp = (op, SideL)}
    where
      op = infixN 1

{-
instance MemoGenLetRecable Viewer where
  group_normalize :: Locus -> Locus -> VLBindings sem -> ([VLBindings sem], VLBindings sem)
  memoGenLetRecLocus :: (Locus -> sem a) -> sem a
  memoGenLetRecLocus f = f
  memoGenLetRec :: Locus -> MemoKey sem -> sem a -> sem a
-}