src/Symantic/Typed/View.hs

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