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   var = Fun.id
  75   lam = viewLam "x"
  76   lam1 = viewLam "u"
  77 viewLam :: String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
  78 viewLam varPrefix f = Viewer Fun.$ \env ->
  79   pairViewer env op Fun.$
  80     let x =
  81           showString varPrefix
  82             Fun.. showsPrec 0 (viewEnv_lamDepth env)
  83      in -- showString "Lam1 (" .
  84         showString "\\" Fun.. x Fun.. showString " -> "
  85           Fun.. runViewer
  86             (f (Viewer (\_env -> x)))
  87             env
  88               { viewEnv_op = (op, SideL)
  89               , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
  90               }
  91   where
  92     -- . showString ")"
  93
  94     op = infixN 0
  95 instance Unabstractable Viewer where
  96   ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
  97     pairViewer env op Fun.$
  98       runViewer x env{viewEnv_op = (op, SideL)}
  99         Fun.. showString " "
 100         Fun.. showString infixName
 101         Fun.. showString " "
 102         Fun.. runViewer y env{viewEnv_op = (op, SideR)}
 103   ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
 104     showParen Prelude.True Fun.$
 105       runViewer x env{viewEnv_op = (op, SideL)}
 106         Fun.. showString " "
 107         Fun.. showString name
 108   f .@ x = ViewerApp f x
 109 instance Anythingable Viewer
 110 instance Bottomable Viewer where
 111   bottom = "<hidden>"
 112 instance Show c => Constantable c Viewer where
 113   constant c = Viewer Fun.$ \_env -> shows c
 114 instance Eitherable Viewer where
 115   either = "either"
 116   left = "Left"
 117   right = "Right"
 118 instance Equalable Viewer where
 119   equal = ViewerInfix (infixN 4) "(==)" "=="
 120 instance Listable Viewer where
 121   cons = ViewerInfix (infixR 5) "(:)" ":"
 122   nil = "[]"
 123 instance Maybeable Viewer where
 124   nothing = "Nothing"
 125   just = "Just"