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.Data
  19 import Symantic.Semantics.Viewer.Fixity
  20 import Symantic.Syntaxes.Classes
  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 Instantiable 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 Unabstractable Viewer where
 106   ap = ViewerInfix (infixL 4) "(<*>)" "<*>"
 107   const = "const"
 108   id = "id"
 109   (.) = ViewerInfix (infixR 9) "(.)" "."
 110   flip = flip
 111   ($) = ViewerInfix (infixR 0) "($)" "$"
 112 instance Varable Viewer where
 113   var = Fun.id
 114 instance Anythingable Viewer
 115 instance Bottomable Viewer where
 116   bottom = "<hidden>"
 117 instance Show c => Constantable c Viewer where
 118   constant c = Viewer Fun.$ \_env -> shows c
 119 instance Eitherable Viewer where
 120   either = "either"
 121   left = "Left"
 122   right = "Right"
 123 instance Equalable Viewer where
 124   equal = ViewerInfix (infixN 4) "(==)" "=="
 125 instance Listable Viewer where
 126   cons = ViewerInfix (infixR 5) "(:)" ":"
 127   nil = "[]"
 128 instance Maybeable Viewer where
 129   nothing = "Nothing"
 130   just = "Just"