src/Symantic/Viewer.hs

   1 {-# LANGUAGE GADTs #-} -- For Viewer
   2 {-# LANGUAGE OverloadedStrings #-} -- For convenience
   3 {-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)
   4 module Symantic.Viewer where
   5
   6 import Data.Int (Int)
   7 import Data.String
   8 import Text.Show
   9 import qualified Data.Function as Fun
  10 import qualified Prelude
  11
  12 import Symantic.Classes
  13 import Symantic.Data
  14 import Symantic.Derive
  15 import Symantic.Fixity
  16
  17 data Viewer a where
  18   Viewer :: (ViewerEnv -> ShowS) -> Viewer a
  19   ViewerUnifix :: Unifix -> String -> String -> Viewer (a -> b)
  20   ViewerInfix :: Infix -> String -> String -> Viewer (a -> b -> c)
  21   ViewerApp :: Viewer (b -> a) -> Viewer b -> Viewer a
  22
  23 runViewer :: Viewer a -> ViewerEnv -> ShowS
  24 runViewer (Viewer v) env = v env
  25 runViewer (ViewerInfix _op name _infixName) _env = showString name
  26 runViewer (ViewerUnifix _op name _unifixName) _env = showString name
  27 runViewer (ViewerApp f x) env =
  28   pairViewer env op Fun.$
  29     runViewer f env{viewEnv_op = (op, SideL) } Fun..
  30     showString " " Fun..
  31     runViewer x env{viewEnv_op = (op, SideR) }
  32   where op = infixN 10
  33
  34 -- | Unusual, but enables to leverage default definition of methods.
  35 type instance Derived Viewer = Viewer
  36 instance LiftDerived Viewer where
  37   liftDerived = Fun.id
  38
  39 instance IsString (Viewer a) where
  40   fromString s = Viewer Fun.$ \_env -> showString s
  41 instance Show (Viewer a) where
  42   showsPrec p = (`runViewer` ViewerEnv
  43     { viewEnv_op = (infixN p, SideL)
  44     , viewEnv_pair = pairParen
  45     , viewEnv_lamDepth = 1
  46     })
  47 instance Show (SomeData Viewer a) where
  48   showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)
  49
  50 data ViewerEnv
  51   = ViewerEnv
  52   { viewEnv_op :: (Infix, Side)
  53   , viewEnv_pair :: Pair
  54   , viewEnv_lamDepth :: Int
  55   }
  56
  57 pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
  58 pairViewer env op s =
  59   if isPairNeeded (viewEnv_op env) op
  60   then showString o Fun.. s Fun.. showString c
  61   else s
  62   where (o,c) = viewEnv_pair env
  63
  64 instance Abstractable Viewer where
  65   var = Fun.id
  66   lam f = viewLam "x" f
  67   lam1 f = viewLam "u" f
  68   ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
  69     pairViewer env op Fun.$
  70       runViewer x env{viewEnv_op=(op, SideL)} Fun..
  71       showString " " Fun.. showString infixName Fun.. showString " " Fun..
  72       runViewer y env{viewEnv_op=(op, SideR)}
  73   ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
  74     showParen Prelude.True Fun.$
  75       runViewer x env{viewEnv_op=(op, SideL)} Fun..
  76       showString " " Fun.. showString name
  77   f .@ x = ViewerApp f x
  78 viewLam :: String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
  79 viewLam varPrefix f = Viewer Fun.$ \env ->
  80   pairViewer env op Fun.$
  81     let x = showString varPrefix Fun..
  82             showsPrec 0 (viewEnv_lamDepth env) in
  83     -- showString "Lam1 (" .
  84     showString "\\" Fun.. x Fun.. showString " -> " Fun..
  85     runViewer (f (Viewer (\_env -> x))) env
  86       { viewEnv_op = (op, SideL)
  87       , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
  88       }
  89     -- . showString ")"
  90   where
  91   op = infixN 0
  92 instance Anythingable Viewer
  93 instance Bottomable Viewer where
  94   bottom = "<hidden>"
  95 instance Show c => Constantable c Viewer where
  96   constant c = Viewer Fun.$ \_env -> shows c
  97 instance Eitherable Viewer where
  98   left = "Left"
  99   right = "Right"
 100 instance Equalable Viewer where
 101   equal = ViewerInfix (infixN 4) "(==)" "=="
 102 instance Listable Viewer where
 103   cons = ViewerInfix (infixR 5) "(:)" ":"
 104   nil = "[]"
 105 instance Maybeable Viewer where
 106   nothing = "Nothing"
 107   just = "Just"