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