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