src/Symantic/View.hs

   1 {-# LANGUAGE GADTs #-} -- For View
   2 {-# LANGUAGE OverloadedStrings #-} -- For convenience
   3 {-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)
   4 module Symantic.View where
   5
   6 import Data.Int (Int)
   7 import Data.String
   8 import Text.Show
   9 import qualified Data.Function as Fun
  10 import qualified Prelude
  11
  12 import Symantic.Fixity
  13 import Symantic.Lang
  14 import Symantic.Data
  15 import Symantic.Derive
  16
  17 data View a where
  18   View :: (ViewEnv -> ShowS) -> View a
  19   ViewUnifix :: Unifix -> String -> String -> View (a -> b)
  20   ViewInfix :: Infix -> String -> String -> View (a -> b -> c)
  21   ViewApp :: View (b -> a) -> View b -> View a
  22
  23 runView :: View a -> ViewEnv -> ShowS
  24 runView (View v) env = v env
  25 runView (ViewInfix _op name _infixName) _env = showString name
  26 runView (ViewUnifix _op name _unifixName) _env = showString name
  27 runView (ViewApp f x) env =
  28   pairView env op Fun.$
  29     runView f env{viewEnv_op = (op, SideL) } Fun..
  30     showString " " Fun..
  31     runView x env{viewEnv_op = (op, SideR) }
  32   where op = infixN 10
  33
  34 -- | Unusual, but enables to leverage default definition of methods.
  35 type instance Derived View = View
  36 instance LiftDerived View where
  37   liftDerived = Fun.id
  38
  39 instance IsString (View a) where
  40   fromString s = View Fun.$ \_env -> showString s
  41 instance Show (View a) where
  42   showsPrec p = (`runView` ViewEnv
  43     { viewEnv_op = (infixN p, SideL)
  44     , viewEnv_pair = pairParen
  45     , viewEnv_lamDepth = 1
  46     })
  47 instance Show (SomeData View a) where
  48   showsPrec p (SomeData x) = showsPrec p (derive x :: View a)
  49
  50 data ViewEnv
  51   = ViewEnv
  52   { viewEnv_op :: (Infix, Side)
  53   , viewEnv_pair :: Pair
  54   , viewEnv_lamDepth :: Int
  55   }
  56
  57 pairView :: ViewEnv -> Infix -> ShowS -> ShowS
  58 pairView env op s =
  59   if isPairNeeded (viewEnv_op env) op
  60   then showString o Fun.. s Fun.. showString c
  61   else s
  62   where (o,c) = viewEnv_pair env
  63
  64 instance Abstractable View where
  65   var = Fun.id
  66   lam f = viewLam "x" f
  67   lam1 f = viewLam "u" f
  68   ViewInfix op _name infixName .@ ViewApp x y = View Fun.$ \env ->
  69     pairView env op Fun.$
  70       runView x env{viewEnv_op=(op, SideL)} Fun..
  71       showString " " Fun.. showString infixName Fun.. showString " " Fun..
  72       runView y env{viewEnv_op=(op, SideR)}
  73   ViewInfix op name _infixName .@ x = View Fun.$ \env ->
  74     showParen Prelude.True Fun.$
  75       runView x env{viewEnv_op=(op, SideL)} Fun..
  76       showString " " Fun.. showString name
  77   f .@ x = ViewApp f x
  78 viewLam :: String -> (View a -> View b) -> View (a -> b)
  79 viewLam varPrefix f = View Fun.$ \env ->
  80   pairView env op Fun.$
  81     let x = showString varPrefix Fun..
  82             showsPrec 0 (viewEnv_lamDepth env) in
  83     -- showString "Lam1 (" .
  84     showString "\\" Fun.. x Fun.. showString " -> " Fun..
  85     runView (f (View (\_env -> x))) env
  86       { viewEnv_op = (op, SideL)
  87       , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
  88       }
  89     -- . showString ")"
  90   where
  91   op = infixN 0
  92 instance Anythingable View
  93 instance Bottomable View where
  94   bottom = "<hidden>"
  95 instance Show c => Constantable c View where
  96   constant c = View Fun.$ \_env -> shows c
  97 instance Eitherable View where
  98   left = "Left"
  99   right = "Right"
 100 instance Equalable View where
 101   equal = ViewInfix (infixN 4) "(==)" "=="
 102 instance Listable View where
 103   cons = ViewInfix (infixR 5) "(:)" ":"
 104   nil = "[]"
 105 instance Maybeable View where
 106   nothing = "Nothing"
 107   just = "Just"