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 view :: Viewer a -> ViewerEnv -> ShowS
  31 view (Viewer v) env = v env
  32 view (ViewerInfix _op name _infixName) _env = showString name
  33 view (ViewerUnifix _op name _unifixName) _env = showString name
  34 view (ViewerApp f x) env =
  35   pairViewer env op Fun.$
  36     view f env{viewEnv_op = (op, SideL)}
  37       Fun.. showString " "
  38       Fun.. view 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     ( `view`
  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.. view
  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 Abstractable1 Viewer where
  92   lam1 f = Viewer Fun.$ \env ->
  93     pairViewer env op Fun.$
  94       let x = showString "u" Fun.. shows (viewEnv_lamDepth env)
  95        in showString "\\"
  96             Fun.. x
  97             Fun.. showString " -> "
  98             Fun.. view
  99               (f (Viewer (\_env -> x)))
 100               env
 101                 { viewEnv_op = (op, SideL)
 102                 , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
 103                 }
 104     where
 105       op = infixN 0
 106 instance Instantiable Viewer where
 107   ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
 108     pairViewer env op Fun.$
 109       view x env{viewEnv_op = (op, SideL)}
 110         Fun.. showString " "
 111         Fun.. showString infixName
 112         Fun.. showString " "
 113         Fun.. view y env{viewEnv_op = (op, SideR)}
 114   ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
 115     showParen Prelude.True Fun.$
 116       view x env{viewEnv_op = (op, SideL)}
 117         Fun.. showString " "
 118         Fun.. showString name
 119   f .@ x = ViewerApp f x
 120 instance Unabstractable Viewer where
 121   ap = ViewerInfix (infixL 4) "(<*>)" "<*>"
 122   const = "const"
 123   id = "id"
 124   (.) = ViewerInfix (infixR 9) "(.)" "."
 125   flip = flip
 126   ($) = ViewerInfix (infixR 0) "($)" "$"
 127 instance Varable Viewer where
 128   var = Fun.id
 129 instance Anythingable Viewer
 130 instance Bottomable Viewer where
 131   bottom = "<hidden>"
 132 instance Show c => Constantable c Viewer where
 133   constant c = Viewer Fun.$ \_env -> shows c
 134 instance Eitherable Viewer where
 135   either = "either"
 136   left = "Left"
 137   right = "Right"
 138 instance Equalable Viewer where
 139   equal = ViewerInfix (infixN 4) "(==)" "=="
 140 instance Listable Viewer where
 141   cons = ViewerInfix (infixR 5) "(:)" ":"
 142   nil = "[]"
 143 instance Maybeable Viewer where
 144   nothing = "Nothing"
 145   just = "Just"
 146 instance IfThenElseable Viewer where
 147   ifThenElse test ok ko = Viewer Fun.$ \env ->
 148     pairViewer env op Fun.$
 149     showString "if"
 150       Fun.. view test env{viewEnv_op = (op, SideL)}
 151       Fun.. showString "then"
 152       Fun.. view ok env{viewEnv_op = (op, SideL)}
 153       Fun.. showString "else"
 154       Fun.. view ko env{viewEnv_op = (op, SideL)}
 155     where
 156     op = infixN 0