{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)
module Symantic.Univariant.View where

import Data.Int (Int)
import Data.Semigroup (Semigroup(..))
import Data.String
import Prelude (undefined)
import Text.Show
import Type.Reflection (Typeable)
import qualified Data.Function as Fun
import qualified Prelude

import Symantic.Parser.Grammar.Fixity
import Symantic.Univariant.Lang
import Symantic.Univariant.Data
import Symantic.Univariant.Trans

data View a where
  View :: (ViewEnv -> ShowS) -> View a
  ViewUnifix :: Unifix -> String -> String -> View (a -> b)
  ViewInfix :: Infix -> String -> String -> View (a -> b -> c)
  ViewApp :: View (b -> a) -> View b -> View a

runView :: View a -> ViewEnv -> ShowS
runView (View f) env = f env
runView (ViewInfix _op name _infixName) env = showString name
runView (ViewApp f x) env =
  pairView env op Fun.$
    runView f env{viewEnv_op = (op, SideL) } Fun..
    showString " " Fun..
    runView x env{viewEnv_op = (op, SideR) }
  where op = infixN 10

type instance Output View = View
instance Trans View View where
  trans = Fun.id

instance IsString (View a) where
  fromString s = View Fun.$ \_env -> showString s
instance Show (View a) where
  showsPrec p (View v) = v ViewEnv
    { viewEnv_op = (infixN p, SideL)
    , viewEnv_pair = pairParen
    , viewEnv_lamDepth = 1
    }
instance Show (SomeData View a) where
  showsPrec p (SomeData x) = showsPrec p (trans @_ @View x)

data ViewEnv
  = ViewEnv
  { viewEnv_op :: (Infix, Side)
  , viewEnv_pair :: Pair
  , viewEnv_lamDepth :: Int
  }

pairView :: ViewEnv -> Infix -> ShowS -> ShowS
pairView env op s =
  if isPairNeeded (viewEnv_op env) op
  then showString o Fun.. s Fun.. showString c
  else s
  where (o,c) = viewEnv_pair env

instance Abstractable View where
  var = Fun.id
  lam f = viewLam "x" f
  lam1 f = viewLam "u" f
  ViewInfix op _name infixName .@ ViewApp x y = View Fun.$ \env ->
    pairView env op Fun.$
      runView x env{viewEnv_op=(op, SideL)} Fun..
      showString " " Fun.. showString infixName Fun.. showString " " Fun..
      runView y env{viewEnv_op=(op, SideR)}
  ViewInfix op name _infixName .@ x = View Fun.$ \env ->
    showParen Prelude.True Fun.$
      runView x env{viewEnv_op=(op, SideL)} Fun..
      showString " " Fun.. showString name
  f .@ x = ViewApp f x
viewLam :: String -> (View a -> View b) -> View (a -> b)
viewLam varPrefix f = View Fun.$ \env ->
  pairView env op Fun.$
    let x = showString varPrefix Fun..
            showsPrec 0 (viewEnv_lamDepth env) in
    -- showString "Lam1 (" .
    showString "\\" Fun.. x Fun.. showString " -> " Fun..
    runView (f (View (\_env -> x))) env
      { viewEnv_op = (op, SideL)
      , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
      }
    -- . showString ")"
  where
  op = infixN 0
instance Anythingable View
instance Bottomable View where
  bottom = "<hidden>"
instance Show c => Constantable c View where
  constant c = View Fun.$ \_env -> shows c
instance Eitherable View where
  left = "Left"
  right = "Right"
instance Equalable View where
  equal = ViewInfix (infixN 4) "(==)" "=="
instance Listable View where
  cons = ViewInfix (infixR 5) "(:)" ":"
  nil = "[]"
instance Maybeable View where
  nothing = "Nothing"
  just = "Just"