View.hs

{-# 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 { unViewTerm :: ViewTermInh -> ShowS }

instance IsString (ViewTerm a) where
  fromString s = ViewTerm $ \_inh -> showString s

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

pairViewTerm :: ViewTermInh -> Infix -> ShowS -> ShowS
pairViewTerm inh op s =
  if isPairNeeded (viewTermInh_op inh) op
  then showString o . s . showString c
  else s
  where (o,c) = viewTermInh_pair inh

instance Show (ViewTerm a) where
  showsPrec p v = unViewTerm v ViewTermInh
    { viewTermInh_op = (infixN p, SideL)
    , viewTermInh_pair = pairParen
    , viewTermInh_lamDepth = 1
    }
instance Show (H.Term repr a) where
  showsPrec p = showsPrec p . go
    where
    go :: forall b. H.Term repr b -> ViewTerm b
    go = \case
      H.Term{} -> "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 t -> ViewTerm $ \_inh -> shows t
      H.Cons H.:@ x H.:@ xs -> ViewTerm $ \inh ->
        pairViewTerm inh op Fun.$
          unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
          showString " : " Fun..
          unViewTerm (go xs) inh{viewTermInh_op=(op, SideR)}
        where op = infixN 5
      H.Cons -> "cons"
      H.Eq H.:@ x H.:@ y -> ViewTerm $ \inh ->
        pairViewTerm inh op Fun.$
          unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
          showString " == " Fun..
          unViewTerm (go y) inh{viewTermInh_op=(op, SideR)}
        where op = infixN 4
      H.Eq H.:@ x -> ViewTerm $ \inh ->
        showParen True Fun.$
          unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
          showString " =="
          where op = infixN 4
      H.Eq -> "(==)"
      H.Var v -> fromString v
      H.Lam1 f -> viewLam "u" f
      H.Lam f -> viewLam "x" f
      f H.:@ x -> ViewTerm $ \inh ->
        pairViewTerm inh op $
          unViewTerm (go f) inh{viewTermInh_op = (op, SideL) } .
          -- showString " :@ " .
          showString " " .
          unViewTerm (go x) inh{viewTermInh_op = (op, SideR) }
        where op = infixN 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 v f = ViewTerm $ \inh ->
      pairViewTerm inh op $
        let x = v<>show (viewTermInh_lamDepth inh) in
        -- showString "Lam1 (" .
        showString "\\" . showString x . showString " -> " .
        (unViewTerm (go (f (H.Var x))) inh
          { viewTermInh_op = (op, SideL)
          , viewTermInh_lamDepth = viewTermInh_lamDepth inh + 1
          })
        -- . showString ")"
      where op = infixN 0