View.hs

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

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

import Symantic.Class
import Symantic.Data
import Symantic.Derive
import Symantic.Fixity

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 v) env = v env
runView (ViewInfix _op name _infixName) _env = showString name
runView (ViewUnifix _op name _unifixName) _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

-- | Unusual, but enables to leverage default definition of methods.
type instance Derived View = View
instance LiftDerived View where
  liftDerived = Fun.id

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

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"