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.Parser.Grammar.Fixity
  22 import Symantic.Typed.Lang
  23 import Symantic.Typed.Data
  24 import Symantic.Typed.Trans
  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 type instance Output View = View
  44 instance Trans View View where
  45   trans = Fun.id
  46
  47 instance IsString (View a) where
  48   fromString s = View Fun.$ \_env -> showString s
  49 instance Show (View a) where
  50   showsPrec p = (`runView` ViewEnv
  51     { viewEnv_op = (infixN p, SideL)
  52     , viewEnv_pair = pairParen
  53     , viewEnv_lamDepth = 1
  54     })
  55 instance Show (SomeData View a) where
  56   showsPrec p (SomeData x) = showsPrec p (trans @_ @View x)
  57
  58 data ViewEnv
  59   = ViewEnv
  60   { viewEnv_op :: (Infix, Side)
  61   , viewEnv_pair :: Pair
  62   , viewEnv_lamDepth :: Int
  63   }
  64
  65 pairView :: ViewEnv -> Infix -> ShowS -> ShowS
  66 pairView env op s =
  67   if isPairNeeded (viewEnv_op env) op
  68   then showString o Fun.. s Fun.. showString c
  69   else s
  70   where (o,c) = viewEnv_pair env
  71
  72 instance Abstractable View where
  73   var = Fun.id
  74   lam f = viewLam "x" f
  75   lam1 f = viewLam "u" f
  76   ViewInfix op _name infixName .@ ViewApp x y = View Fun.$ \env ->
  77     pairView env op Fun.$
  78       runView x env{viewEnv_op=(op, SideL)} Fun..
  79       showString " " Fun.. showString infixName Fun.. showString " " Fun..
  80       runView y env{viewEnv_op=(op, SideR)}
  81   ViewInfix op name _infixName .@ x = View Fun.$ \env ->
  82     showParen Prelude.True Fun.$
  83       runView x env{viewEnv_op=(op, SideL)} Fun..
  84       showString " " Fun.. showString name
  85   f .@ x = ViewApp f x
  86 viewLam :: String -> (View a -> View b) -> View (a -> b)
  87 viewLam varPrefix f = View Fun.$ \env ->
  88   pairView env op Fun.$
  89     let x = showString varPrefix Fun..
  90             showsPrec 0 (viewEnv_lamDepth env) in
  91     -- showString "Lam1 (" .
  92     showString "\\" Fun.. x Fun.. showString " -> " Fun..
  93     runView (f (View (\_env -> x))) env
  94       { viewEnv_op = (op, SideL)
  95       , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
  96       }
  97     -- . showString ")"
  98   where
  99   op = infixN 0
 100 instance Anythingable View
 101 instance Bottomable View where
 102   bottom = "<hidden>"
 103 instance Show c => Constantable c View where
 104   constant c = View Fun.$ \_env -> shows c
 105 instance Eitherable View where
 106   left = "Left"
 107   right = "Right"
 108 instance Equalable View where
 109   equal = ViewInfix (infixN 4) "(==)" "=="
 110 instance Listable View where
 111   cons = ViewInfix (infixR 5) "(:)" ":"
 112   nil = "[]"
 113 instance Maybeable View where
 114   nothing = "Nothing"
 115   just = "Just"