{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Haskell.View where

import Data.Bool
import Data.Function (($), (.))
import Data.Int (Int)
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..), String)
import Prelude ((+))
import Text.Show (Show(..), ShowS, shows, showParen, showString)
import qualified Data.Function as Fun

import Symantic.Parser.Grammar.Fixity
import qualified Symantic.Parser.Haskell.Optimize as H

-- * Type 'ViewTerm'
newtype ViewTerm a = ViewTerm { forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm :: ViewTermInh -> ShowS }

instance IsString (ViewTerm a) where
  fromString :: String -> ViewTerm a
fromString String
s = (ViewTermInh -> ShowS) -> ViewTerm a
forall a. (ViewTermInh -> ShowS) -> ViewTerm a
ViewTerm ((ViewTermInh -> ShowS) -> ViewTerm a)
-> (ViewTermInh -> ShowS) -> ViewTerm a
forall a b. (a -> b) -> a -> b
$ \ViewTermInh
_inh -> String -> ShowS
showString String
s

-- ** Type 'ViewTermInh'
data ViewTermInh
 =   ViewTermInh
 {   ViewTermInh -> (Infix, Side)
viewTermInh_op :: (Infix, Side)
 ,   ViewTermInh -> Pair
viewTermInh_pair :: Pair
 ,   ViewTermInh -> Int
viewTermInh_lamDepth :: Int
 }

pairViewTerm :: ViewTermInh -> Infix -> ShowS -> ShowS
pairViewTerm :: ViewTermInh -> Infix -> ShowS -> ShowS
pairViewTerm ViewTermInh
inh Infix
op ShowS
s =
  if (Infix, Side) -> Infix -> Bool
isPairNeeded (ViewTermInh -> (Infix, Side)
viewTermInh_op ViewTermInh
inh) Infix
op
  then String -> ShowS
showString String
o ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
c
  else ShowS
s
  where (String
o,String
c) = ViewTermInh -> Pair
viewTermInh_pair ViewTermInh
inh

instance Show (ViewTerm a) where
  showsPrec :: Int -> ViewTerm a -> ShowS
showsPrec Int
p ViewTerm a
v = ViewTerm a -> ViewTermInh -> ShowS
forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm ViewTerm a
v ViewTermInh :: (Infix, Side) -> Pair -> Int -> ViewTermInh
ViewTermInh
    { viewTermInh_op :: (Infix, Side)
viewTermInh_op = (Int -> Infix
infixN Int
p, Side
SideL)
    , viewTermInh_pair :: Pair
viewTermInh_pair = Pair
pairParen
    , viewTermInh_lamDepth :: Int
viewTermInh_lamDepth = Int
1
    }
instance Show (H.Term repr a) where
  showsPrec :: Int -> Term repr a -> ShowS
showsPrec Int
p = Int -> ViewTerm a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (ViewTerm a -> ShowS)
-> (Term repr a -> ViewTerm a) -> Term repr a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term repr a -> ViewTerm a
forall b. Term repr b -> ViewTerm b
go
    where
    go :: forall b. H.Term repr b -> ViewTerm b
    go :: forall b. Term repr b -> ViewTerm b
go = \case
      H.Term{} -> ViewTerm b
"Term"
      {-
      (H.:.) H.:@ f H.:@ g -> ViewTerm $ \inh ->
        pairViewTerm inh op Fun.$
          unViewTerm (go f) inh{viewTermInh_op=op} Fun..
          showString " . " Fun..
          unViewTerm (go g) inh{viewTermInh_op=op}
        where op = infixR 9
      (H.:.) -> "(.)"
      -}
      {-
      H.Char t -> ViewTerm $ \_inh ->
        showString "(char " .
        shows t .
        showString ")"
      -}
      H.Char b
t -> (ViewTermInh -> ShowS) -> ViewTerm b
forall a. (ViewTermInh -> ShowS) -> ViewTerm a
ViewTerm ((ViewTermInh -> ShowS) -> ViewTerm b)
-> (ViewTermInh -> ShowS) -> ViewTerm b
forall a b. (a -> b) -> a -> b
$ \ViewTermInh
_inh -> b -> ShowS
forall a. Show a => a -> ShowS
shows b
t
      Term repr (a -> a -> b)
H.Cons H.:@ Term repr a
x H.:@ Term repr a
xs -> (ViewTermInh -> ShowS) -> ViewTerm b
forall a. (ViewTermInh -> ShowS) -> ViewTerm a
ViewTerm ((ViewTermInh -> ShowS) -> ViewTerm b)
-> (ViewTermInh -> ShowS) -> ViewTerm b
forall a b. (a -> b) -> a -> b
$ \ViewTermInh
inh ->
        ViewTermInh -> Infix -> ShowS -> ShowS
pairViewTerm ViewTermInh
inh Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
          ViewTerm a -> ViewTermInh -> ShowS
forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm (Term repr a -> ViewTerm a
forall b. Term repr b -> ViewTerm b
go Term repr a
x) ViewTermInh
inh{viewTermInh_op :: (Infix, Side)
viewTermInh_op=(Infix
op, Side
SideL)} ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
          String -> ShowS
showString String
" : " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
          ViewTerm a -> ViewTermInh -> ShowS
forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm (Term repr a -> ViewTerm a
forall b. Term repr b -> ViewTerm b
go Term repr a
xs) ViewTermInh
inh{viewTermInh_op :: (Infix, Side)
viewTermInh_op=(Infix
op, Side
SideR)}
        where op :: Infix
op = Int -> Infix
infixN Int
5
      Term repr b
H.Cons -> ViewTerm b
"cons"
      Term repr (a -> a -> b)
H.Eq H.:@ Term repr a
x H.:@ Term repr a
y -> (ViewTermInh -> ShowS) -> ViewTerm b
forall a. (ViewTermInh -> ShowS) -> ViewTerm a
ViewTerm ((ViewTermInh -> ShowS) -> ViewTerm b)
-> (ViewTermInh -> ShowS) -> ViewTerm b
forall a b. (a -> b) -> a -> b
$ \ViewTermInh
inh ->
        ViewTermInh -> Infix -> ShowS -> ShowS
pairViewTerm ViewTermInh
inh Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
          ViewTerm a -> ViewTermInh -> ShowS
forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm (Term repr a -> ViewTerm a
forall b. Term repr b -> ViewTerm b
go Term repr a
x) ViewTermInh
inh{viewTermInh_op :: (Infix, Side)
viewTermInh_op=(Infix
op, Side
SideL)} ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
          String -> ShowS
showString String
" == " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
          ViewTerm a -> ViewTermInh -> ShowS
forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm (Term repr a -> ViewTerm a
forall b. Term repr b -> ViewTerm b
go Term repr a
y) ViewTermInh
inh{viewTermInh_op :: (Infix, Side)
viewTermInh_op=(Infix
op, Side
SideR)}
        where op :: Infix
op = Int -> Infix
infixN Int
4
      Term repr (a -> b)
H.Eq H.:@ Term repr a
x -> (ViewTermInh -> ShowS) -> ViewTerm b
forall a. (ViewTermInh -> ShowS) -> ViewTerm a
ViewTerm ((ViewTermInh -> ShowS) -> ViewTerm b)
-> (ViewTermInh -> ShowS) -> ViewTerm b
forall a b. (a -> b) -> a -> b
$ \ViewTermInh
inh ->
        Bool -> ShowS -> ShowS
showParen Bool
True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
          ViewTerm a -> ViewTermInh -> ShowS
forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm (Term repr a -> ViewTerm a
forall b. Term repr b -> ViewTerm b
go Term repr a
x) ViewTermInh
inh{viewTermInh_op :: (Infix, Side)
viewTermInh_op=(Infix
op, Side
SideL)} ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
          String -> ShowS
showString String
" =="
          where op :: Infix
op = Int -> Infix
infixN Int
4
      Term repr b
H.Eq -> ViewTerm b
"(==)"
      H.Var String
v -> String -> ViewTerm b
forall a. IsString a => String -> a
fromString String
v
      H.Lam1 Term repr a -> Term repr b
f -> String -> (Term repr a -> Term repr b) -> ViewTerm (a -> b)
forall b c.
String -> (Term repr b -> Term repr c) -> ViewTerm (b -> c)
viewLam String
"u" Term repr a -> Term repr b
f
      H.Lam Term repr a -> Term repr b
f -> String -> (Term repr a -> Term repr b) -> ViewTerm (a -> b)
forall b c.
String -> (Term repr b -> Term repr c) -> ViewTerm (b -> c)
viewLam String
"x" Term repr a -> Term repr b
f
      Term repr (a -> b)
f H.:@ Term repr a
x -> (ViewTermInh -> ShowS) -> ViewTerm b
forall a. (ViewTermInh -> ShowS) -> ViewTerm a
ViewTerm ((ViewTermInh -> ShowS) -> ViewTerm b)
-> (ViewTermInh -> ShowS) -> ViewTerm b
forall a b. (a -> b) -> a -> b
$ \ViewTermInh
inh ->
        ViewTermInh -> Infix -> ShowS -> ShowS
pairViewTerm ViewTermInh
inh Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          ViewTerm (a -> b) -> ViewTermInh -> ShowS
forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm (Term repr (a -> b) -> ViewTerm (a -> b)
forall b. Term repr b -> ViewTerm b
go Term repr (a -> b)
f) ViewTermInh
inh{viewTermInh_op :: (Infix, Side)
viewTermInh_op = (Infix
op, Side
SideL) } ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          -- showString " :@ " .
          String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          ViewTerm a -> ViewTermInh -> ShowS
forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm (Term repr a -> ViewTerm a
forall b. Term repr b -> ViewTerm b
go Term repr a
x) ViewTermInh
inh{viewTermInh_op :: (Infix, Side)
viewTermInh_op = (Infix
op, Side
SideR) }
        where op :: Infix
op = Int -> Infix
infixN Int
10
      {-
      H.Const -> "const"
      H.Flip -> "flip"
      H.Id -> "id"
      (H.:$) -> "($)"
      -}
    viewLam :: forall b c. String -> (H.Term repr b -> H.Term repr c) -> ViewTerm (b -> c)
    viewLam :: forall b c.
String -> (Term repr b -> Term repr c) -> ViewTerm (b -> c)
viewLam String
v Term repr b -> Term repr c
f = (ViewTermInh -> ShowS) -> ViewTerm (b -> c)
forall a. (ViewTermInh -> ShowS) -> ViewTerm a
ViewTerm ((ViewTermInh -> ShowS) -> ViewTerm (b -> c))
-> (ViewTermInh -> ShowS) -> ViewTerm (b -> c)
forall a b. (a -> b) -> a -> b
$ \ViewTermInh
inh ->
      ViewTermInh -> Infix -> ShowS -> ShowS
pairViewTerm ViewTermInh
inh Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        let x :: String
x = String
vString -> ShowS
forall a. Semigroup a => a -> a -> a
<>Int -> String
forall a. Show a => a -> String
show (ViewTermInh -> Int
viewTermInh_lamDepth ViewTermInh
inh) in
        -- showString "Lam1 (" .
        String -> ShowS
showString String
"\\" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" -> " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (ViewTerm c -> ViewTermInh -> ShowS
forall a. ViewTerm a -> ViewTermInh -> ShowS
unViewTerm (Term repr c -> ViewTerm c
forall b. Term repr b -> ViewTerm b
go (Term repr b -> Term repr c
f (String -> Term repr b
forall (repr :: * -> *) a. String -> Term repr a
H.Var String
x))) ViewTermInh
inh
          { viewTermInh_op :: (Infix, Side)
viewTermInh_op = (Infix
op, Side
SideL)
          , viewTermInh_lamDepth :: Int
viewTermInh_lamDepth = ViewTermInh -> Int
viewTermInh_lamDepth ViewTermInh
inh Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
          })
        -- . showString ")"
      where op :: Infix
op = Int -> Infix
infixN Int
0