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.String
  14 import Numeric.Natural (Natural)
  15 import Prelude qualified
  16 import Text.Show
  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{viewerEnvOp = (op, SideL)}
  37       Fun.. showString " "
  38       Fun.. view x env{viewerEnvOp = (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           { viewerEnvOp = (infixN p, SideL)
  55           , viewerEnvPair = pairParen
  56           , viewerEnvLamDepth = 1
  57           }
  58     )
  59 instance Show (SomeData Viewer a) where
  60   showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)
  61
  62 -- ** Type 'ViewerEnv'
  63 data ViewerEnv = ViewerEnv
  64   { viewerEnvOp :: (Infix, Side)
  65   , viewerEnvPair :: Pair
  66   , viewerEnvLamDepth :: Natural
  67   }
  68
  69 pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
  70 pairViewer env op s =
  71   if isPairNeeded (viewerEnvOp env) op
  72     then showString o Fun.. s Fun.. showString c
  73     else s
  74   where
  75     (o, c) = viewerEnvPair env
  76
  77 instance Abstractable Viewer where
  78   lam f = Viewer Fun.$ \env ->
  79     pairViewer env op Fun.$
  80       let x = showString "x" Fun.. shows (viewerEnvLamDepth env)
  81        in showString "\\"
  82             Fun.. x
  83             Fun.. showString " -> "
  84             Fun.. view
  85               (f (Viewer (\_env -> x)))
  86               env
  87                 { viewerEnvOp = (op, SideL)
  88                 , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
  89                 }
  90     where
  91       op = infixN 0
  92 instance Abstractable1 Viewer where
  93   lam1 f = Viewer Fun.$ \env ->
  94     pairViewer env op Fun.$
  95       let x = showString "u" Fun.. shows (viewerEnvLamDepth env)
  96        in showString "\\"
  97             Fun.. x
  98             Fun.. showString " -> "
  99             Fun.. view
 100               (f (Viewer (\_env -> x)))
 101               env
 102                 { viewerEnvOp = (op, SideL)
 103                 , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
 104                 }
 105     where
 106       op = infixN 0
 107 instance Instantiable Viewer where
 108   ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
 109     pairViewer env op Fun.$
 110       view x env{viewerEnvOp = (op, SideL)}
 111         Fun.. showString " "
 112         Fun.. showString infixName
 113         Fun.. showString " "
 114         Fun.. view y env{viewerEnvOp = (op, SideR)}
 115   ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
 116     showParen Prelude.True Fun.$
 117       view x env{viewerEnvOp = (op, SideL)}
 118         Fun.. showString " "
 119         Fun.. showString name
 120   f .@ x = ViewerApp f x
 121 instance Unabstractable Viewer where
 122   ap = ViewerInfix (infixL 4) "(<*>)" "<*>"
 123   const = "const"
 124   id = "id"
 125   (.) = ViewerInfix (infixR 9) "(.)" "."
 126   flip = flip
 127   ($) = ViewerInfix (infixR 0) "($)" "$"
 128 instance Varable Viewer where
 129   var = Fun.id
 130 instance Anythingable Viewer
 131 instance Bottomable Viewer where
 132   bottom = "<hidden>"
 133 instance Show c => Constantable c Viewer where
 134   constant c = Viewer Fun.$ \_env -> shows c
 135 instance Eitherable Viewer where
 136   either = "either"
 137   left = "Left"
 138   right = "Right"
 139 instance Equalable Viewer where
 140   equal = ViewerInfix (infixN 4) "(==)" "=="
 141 instance Listable Viewer where
 142   cons = ViewerInfix (infixR 5) "(:)" ":"
 143   nil = "[]"
 144 instance Maybeable Viewer where
 145   nothing = "Nothing"
 146   just = "Just"
 147 instance IfThenElseable Viewer where
 148   ifThenElse test ok ko = Viewer Fun.$ \env ->
 149     pairViewer env op Fun.$
 150     showString "if"
 151       Fun.. view test env{viewerEnvOp = (op, SideL)}
 152       Fun.. showString "then"
 153       Fun.. view ok env{viewerEnvOp = (op, SideL)}
 154       Fun.. showString "else"
 155       Fun.. view ko env{viewerEnvOp = (op, SideL)}
 156     where
 157     op = infixN 0