-- For Viewer {-# LANGUAGE GADTs #-} -- For convenience {-# LANGUAGE OverloadedStrings #-} -- For Show (SomeData a) {-# LANGUAGE UndecidableInstances #-} -- | This module provides the 'Viewer' semantic -- which interprets combinators as human-readable text. module Symantic.Semantics.Viewer where import Data.Function qualified as Fun import Data.Int (Int) import Data.String import Text.Show import Prelude qualified import Symantic.Semantics.Data import Symantic.Semantics.Viewer.Fixity import Symantic.Syntaxes.Classes import Symantic.Syntaxes.Derive -- * Type 'Viewer' data Viewer a where Viewer :: (ViewerEnv -> ShowS) -> Viewer a ViewerUnifix :: Unifix -> String -> String -> Viewer (a -> b) ViewerInfix :: Infix -> String -> String -> Viewer (a -> b -> c) ViewerApp :: Viewer (b -> a) -> Viewer b -> Viewer a runViewer :: Viewer a -> ViewerEnv -> ShowS runViewer (Viewer v) env = v env runViewer (ViewerInfix _op name _infixName) _env = showString name runViewer (ViewerUnifix _op name _unifixName) _env = showString name runViewer (ViewerApp f x) env = pairViewer env op Fun.$ runViewer f env{viewEnv_op = (op, SideL)} Fun.. showString " " Fun.. runViewer x env{viewEnv_op = (op, SideR)} where op = infixN 10 -- | Unusual, but enables to leverage default definition of methods. type instance Derived Viewer = Viewer instance LiftDerived Viewer where liftDerived = Fun.id instance IsString (Viewer a) where fromString s = Viewer Fun.$ \_env -> showString s instance Show (Viewer a) where showsPrec p = ( `runViewer` ViewerEnv { viewEnv_op = (infixN p, SideL) , viewEnv_pair = pairParen , viewEnv_lamDepth = 1 } ) instance Show (SomeData Viewer a) where showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a) data ViewerEnv = ViewerEnv { viewEnv_op :: (Infix, Side) , viewEnv_pair :: Pair , viewEnv_lamDepth :: Int } pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS pairViewer env op s = if isPairNeeded (viewEnv_op env) op then showString o Fun.. s Fun.. showString c else s where (o, c) = viewEnv_pair env instance Abstractable Viewer where lam f = Viewer Fun.$ \env -> pairViewer env op Fun.$ let x = showString "x" Fun.. shows (viewEnv_lamDepth env) in showString "\\" Fun.. x Fun.. showString " -> " Fun.. runViewer (f (Viewer (\_env -> x))) env { viewEnv_op = (op, SideL) , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env) } where op = infixN 0 instance Abstractable1 Viewer where lam1 f = Viewer Fun.$ \env -> pairViewer env op Fun.$ let x = showString "u" Fun.. shows (viewEnv_lamDepth env) in showString "\\" Fun.. x Fun.. showString " -> " Fun.. runViewer (f (Viewer (\_env -> x))) env { viewEnv_op = (op, SideL) , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env) } where op = infixN 0 instance Instantiable Viewer where ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env -> pairViewer env op Fun.$ runViewer x env{viewEnv_op = (op, SideL)} Fun.. showString " " Fun.. showString infixName Fun.. showString " " Fun.. runViewer y env{viewEnv_op = (op, SideR)} ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env -> showParen Prelude.True Fun.$ runViewer x env{viewEnv_op = (op, SideL)} Fun.. showString " " Fun.. showString name f .@ x = ViewerApp f x instance Unabstractable Viewer where ap = ViewerInfix (infixL 4) "(<*>)" "<*>" const = "const" id = "id" (.) = ViewerInfix (infixR 9) "(.)" "." flip = flip ($) = ViewerInfix (infixR 0) "($)" "$" instance Varable Viewer where var = Fun.id instance Anythingable Viewer instance Bottomable Viewer where bottom = "" instance Show c => Constantable c Viewer where constant c = Viewer Fun.$ \_env -> shows c instance Eitherable Viewer where either = "either" left = "Left" right = "Right" instance Equalable Viewer where equal = ViewerInfix (infixN 4) "(==)" "==" instance Listable Viewer where cons = ViewerInfix (infixR 5) "(:)" ":" nil = "[]" instance Maybeable Viewer where nothing = "Nothing" just = "Just" instance IfThenElseable Viewer where ifThenElse test ok ko = Viewer Fun.$ \env -> pairViewer env op Fun.$ showString "if" Fun.. runViewer test env{viewEnv_op = (op, SideL)} Fun.. showString "then" Fun.. runViewer ok env{viewEnv_op = (op, SideL)} Fun.. showString "else" Fun.. runViewer ko env{viewEnv_op = (op, SideL)} where op = infixN 0