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 -- However there is no wrapping nor indenting.
  11 module Symantic.Semantics.Viewer where
  12
  13 import Data.Function qualified as Fun
  14 import Data.Int (Int)
  15 import Data.List qualified as List
  16 import Data.String
  17 import Numeric.Natural (Natural)
  18 import Text.Show
  19 import Prelude qualified
  20
  21 import Symantic.Semantics.Data
  22 import Symantic.Semantics.LetInserter
  23 import Symantic.Semantics.Viewer.Fixity
  24 import Symantic.Syntaxes.Classes
  25 import Symantic.Syntaxes.Derive
  26
  27 -- * Type 'Viewer'
  28 data Viewer a where
  29   Viewer :: (ViewerEnv -> ShowS) -> Viewer a
  30   ViewerUnifix :: Unifix -> String -> String -> Viewer (a -> b)
  31   ViewerInfix :: Infix -> String -> String -> Viewer (a -> b -> c)
  32   ViewerApp :: Viewer (b -> a) -> Viewer b -> Viewer a
  33
  34 view :: Viewer a -> String
  35 view v =
  36   runView
  37     v
  38     ViewerEnv
  39       { viewerEnvOp = (infixN 0, SideL)
  40       , viewerEnvPair = pairParen
  41       , viewerEnvLamDepth = 1
  42       }
  43     ""
  44
  45 runView :: Viewer a -> ViewerEnv -> ShowS
  46 runView (Viewer v) env = v env
  47 runView (ViewerInfix _op name _infixName) _env = showString name
  48 runView (ViewerUnifix _op name _unifixName) _env = showString name
  49 runView (ViewerApp f x) env =
  50   pairViewer env op Fun.$
  51     runView f env{viewerEnvOp = (op, SideL)}
  52       Fun.. showString " "
  53       Fun.. runView x env{viewerEnvOp = (op, SideR)}
  54   where
  55     op = infixL 10
  56
  57 -- | Unusual, but enables to leverage default definition of methods.
  58 type instance Derived Viewer = Viewer
  59
  60 instance LiftDerived Viewer where
  61   liftDerived = Fun.id
  62
  63 instance IsString (Viewer a) where
  64   fromString s = Viewer Fun.$ \_env -> showString s
  65 instance Show (Viewer a) where
  66   showsPrec p v =
  67     runView
  68       v
  69       ViewerEnv
  70         { viewerEnvOp = (infixN p, SideL)
  71         , viewerEnvPair = pairParen
  72         , viewerEnvLamDepth = 1
  73         }
  74 instance Show (SomeData Viewer a) where
  75   showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)
  76
  77 -- ** Type 'ViewerEnv'
  78 data ViewerEnv = ViewerEnv
  79   { viewerEnvOp :: (Infix, Side)
  80   , viewerEnvPair :: Pair
  81   , viewerEnvLamDepth :: Natural
  82   }
  83
  84 pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
  85 pairViewer env op s =
  86   if isPairNeeded (viewerEnvOp env) op
  87     then showString o Fun.. s Fun.. showString c
  88     else s
  89   where
  90     (o, c) = viewerEnvPair env
  91
  92 instance Abstractable Viewer where
  93   lam f = Viewer Fun.$ \env ->
  94     pairViewer env op Fun.$
  95       let x = showString "x" Fun.. shows (viewerEnvLamDepth env)
  96       in showString "\\"
  97           Fun.. x
  98           Fun.. showString " -> "
  99           Fun.. runView
 100             (f (Viewer (\_env -> x)))
 101             env
 102               { viewerEnvOp = (op, SideL)
 103               , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
 104               }
 105     where
 106       op = infixL 1
 107 instance Letable Viewer where
 108   let_ x f = Viewer Fun.$ \env ->
 109     pairViewer env op Fun.$
 110       let l = showString "x" Fun.. shows (viewerEnvLamDepth env)
 111       in showString "let "
 112           Fun.. l
 113           Fun.. showString " = "
 114           Fun.. runView
 115             x
 116             env
 117               { viewerEnvOp = (infixN 0, SideL)
 118               , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
 119               }
 120           Fun.. showString " in "
 121           Fun.. runView
 122             (f (Viewer (\_env -> l)))
 123             env
 124               { viewerEnvOp = (infixN 0, SideL)
 125               , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
 126               }
 127     where
 128       op = infixL 1
 129 instance LetRecable Int Viewer where
 130   letRec len f body = Viewer Fun.$ \env ->
 131     let fns =
 132           [ showString "u" Fun.. shows (viewerEnvLamDepth env Prelude.+ Prelude.fromIntegral idx)
 133           | idx <- [0 .. len Prelude.- 1]
 134           ]
 135     in let self idx = Viewer Fun.$ \_env -> fns List.!! idx
 136        in let lvs = List.zipWith (\v idx -> (v, f self idx)) fns [0 .. len Prelude.- 1]
 137           in pairViewer env op Fun.$
 138               showString "letRec "
 139                 Fun.. showListWith
 140                   ( \(lhs, rhs) ->
 141                       lhs
 142                         Fun.. showString " = "
 143                         Fun.. runView
 144                           rhs
 145                           env
 146                             { viewerEnvOp = (infixN 0, SideL)
 147                             , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
 148                             }
 149                   )
 150                   lvs
 151                 Fun.. showString " in "
 152                 Fun.. runView
 153                   (body self)
 154                   env
 155                     { viewerEnvOp = (infixN 0, SideL)
 156                     , viewerEnvLamDepth = viewerEnvLamDepth env Prelude.+ Prelude.fromIntegral len
 157                     }
 158     where
 159       op = infixN 10
 160 instance Abstractable1 Viewer where
 161   lam1 f = Viewer Fun.$ \env ->
 162     pairViewer env op Fun.$
 163       let x = showString "u" Fun.. shows (viewerEnvLamDepth env)
 164       in showString "\\"
 165           Fun.. x
 166           Fun.. showString " -> "
 167           Fun.. runView
 168             (f (Viewer (\_env -> x)))
 169             env
 170               { viewerEnvOp = (op, SideL)
 171               , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
 172               }
 173     where
 174       op = infixN 0
 175 instance Instantiable Viewer where
 176   ViewerApp (ViewerInfix op _name infixName) x .@ y = Viewer Fun.$ \env ->
 177     pairViewer env op Fun.$
 178       runView x env{viewerEnvOp = (op, SideL)}
 179         Fun.. showString " "
 180         Fun.. showString infixName
 181         Fun.. showString " "
 182         Fun.. runView y env{viewerEnvOp = (op, SideR)}
 183   f .@ x = ViewerApp f x
 184 instance Unabstractable Viewer where
 185   ap = ViewerInfix (infixL 4) "(<*>)" "<*>"
 186   const = "const"
 187   id = "id"
 188   (.) = ViewerInfix (infixR 9) "(.)" "."
 189   flip = flip
 190   ($) = ViewerInfix (infixR 0) "($)" "$"
 191 instance Varable Viewer where
 192   var = Fun.id
 193 instance Anythingable Viewer
 194 instance Bottomable Viewer where
 195   bottom = "<hidden>"
 196 instance Show c => Constantable c Viewer where
 197   constant c = Viewer Fun.$ \_env -> shows c
 198 instance Eitherable Viewer where
 199   either = "either"
 200   left = "Left"
 201   right = "Right"
 202 instance Equalable Viewer where
 203   equal = ViewerInfix (infixN 4) "(==)" "=="
 204 instance Listable Viewer where
 205   cons = ViewerInfix (infixR 5) "(:)" ":"
 206   nil = "[]"
 207 instance Maybeable Viewer where
 208   nothing = "Nothing"
 209   just = "Just"
 210 instance IfThenElseable Viewer where
 211   ifThenElse test ok ko = Viewer Fun.$ \env ->
 212     pairViewer env op Fun.$
 213       showString "if "
 214         Fun.. runView test env{viewerEnvOp = (op, SideL)}
 215         Fun.. showString " then "
 216         Fun.. runView ok env{viewerEnvOp = (op, SideL)}
 217         Fun.. showString " else "
 218         Fun.. runView ko env{viewerEnvOp = (op, SideL)}
 219     where
 220       op = infixN 1
 221
 222 {-
 223 instance MemoGenLetRecable Viewer where
 224   group_normalize :: Locus -> Locus -> VLBindings sem -> ([VLBindings sem], VLBindings sem)
 225   memoGenLetRecLocus :: (Locus -> sem a) -> sem a
 226   memoGenLetRecLocus f = f
 227   memoGenLetRec :: Locus -> MemoKey sem -> sem a -> sem a
 228 -}