Viewer.hs

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

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

import Symantic.Classes
import Symantic.Data
import Symantic.Derive
import Symantic.Fixity

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

runViewer :: Viewer a -> ViewerEnv -> ShowS
runViewer (Viewer v) env = v env
runViewer (ViewerInfix _op name _infixName) _env = showString name
runViewer (ViewerUnifix _op name _unifixName) _env = showString name
runViewer (ViewerApp f x) env =
  pairViewer env op Fun.$
    runViewer f env{viewEnv_op = (op, SideL) } Fun..
    showString " " Fun..
    runViewer x env{viewEnv_op = (op, SideR) }
  where op = infixN 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 = (`runViewer` ViewerEnv
    { viewEnv_op = (infixN p, SideL)
    , viewEnv_pair = pairParen
    , viewEnv_lamDepth = 1
    })
instance Show (SomeData Viewer a) where
  showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)

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

pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
pairViewer 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 Viewer where
  var = Fun.id
  lam f = viewLam "x" f
  lam1 f = viewLam "u" f
  ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      runViewer x env{viewEnv_op=(op, SideL)} Fun..
      showString " " Fun.. showString infixName Fun.. showString " " Fun..
      runViewer y env{viewEnv_op=(op, SideR)}
  ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
    showParen Prelude.True Fun.$
      runViewer x env{viewEnv_op=(op, SideL)} Fun..
      showString " " Fun.. showString name
  f .@ x = ViewerApp f x
viewLam :: String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
viewLam varPrefix f = Viewer Fun.$ \env ->
  pairViewer env op Fun.$
    let x = showString varPrefix Fun..
            showsPrec 0 (viewEnv_lamDepth env) in
    -- showString "Lam1 (" .
    showString "\\" Fun.. x Fun.. showString " -> " Fun..
    runViewer (f (Viewer (\_env -> x))) env
      { viewEnv_op = (op, SideL)
      , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
      }
    -- . showString ")"
  where
  op = infixN 0
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
  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"