src/Symantic/Semantics/Viewer.hs

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