{-# LANGUAGE GADTs #-} -- For View
{-# LANGUAGE OverloadedStrings #-} -- For convenience
{-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)
module Symantic.View where

import Data.Int (Int)
import Data.String
import Text.Show
import qualified Data.Function as Fun
import qualified Prelude

import Symantic.Fixity
import Symantic.Lang
import Symantic.Data
import Symantic.Derive

data View a where
  View :: (ViewEnv -> ShowS) -> View a
  ViewUnifix :: Unifix -> String -> String -> View (a -> b)
  ViewInfix :: Infix -> String -> String -> View (a -> b -> c)
  ViewApp :: View (b -> a) -> View b -> View a

runView :: View a -> ViewEnv -> ShowS
runView :: View a -> ViewEnv -> ShowS
runView (View ViewEnv -> ShowS
v) ViewEnv
env = ViewEnv -> ShowS
v ViewEnv
env
runView (ViewInfix Infix
_op String
name String
_infixName) ViewEnv
_env = String -> ShowS
showString String
name
runView (ViewUnifix Unifix
_op String
name String
_unifixName) ViewEnv
_env = String -> ShowS
showString String
name
runView (ViewApp View (b -> a)
f View b
x) ViewEnv
env =
  ViewEnv -> Infix -> ShowS -> ShowS
pairView ViewEnv
env Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
    View (b -> a) -> ViewEnv -> ShowS
forall a. View a -> ViewEnv -> ShowS
runView View (b -> a)
f ViewEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op = (Infix
op, Side
SideL) } ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
    String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
    View b -> ViewEnv -> ShowS
forall a. View a -> ViewEnv -> ShowS
runView View b
x ViewEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op = (Infix
op, Side
SideR) }
  where op :: Infix
op = Precedence -> Infix
infixN Precedence
10

-- | Unusual, but enables to leverage default definition of methods.
type instance Derived View = View
instance LiftDerived View where
  liftDerived :: Derived View a -> View a
liftDerived = Derived View a -> View a
forall a. a -> a
Fun.id

instance IsString (View a) where
  fromString :: String -> View a
fromString String
s = (ViewEnv -> ShowS) -> View a
forall a. (ViewEnv -> ShowS) -> View a
View ((ViewEnv -> ShowS) -> View a) -> (ViewEnv -> ShowS) -> View a
forall a b. (a -> b) -> a -> b
Fun.$ \ViewEnv
_env -> String -> ShowS
showString String
s
instance Show (View a) where
  showsPrec :: Precedence -> View a -> ShowS
showsPrec Precedence
p = (View a -> ViewEnv -> ShowS
forall a. View a -> ViewEnv -> ShowS
`runView` ViewEnv :: (Infix, Side) -> Pair -> Precedence -> ViewEnv
ViewEnv
    { viewEnv_op :: (Infix, Side)
viewEnv_op = (Precedence -> Infix
infixN Precedence
p, Side
SideL)
    , viewEnv_pair :: Pair
viewEnv_pair = Pair
pairParen
    , viewEnv_lamDepth :: Precedence
viewEnv_lamDepth = Precedence
1
    })
instance Show (SomeData View a) where
  showsPrec :: Precedence -> SomeData View a -> ShowS
showsPrec Precedence
p (SomeData Data able View a
x) = Precedence -> View a -> ShowS
forall a. Show a => Precedence -> a -> ShowS
showsPrec Precedence
p (Data able View a -> Derived (Data able View) a
forall (repr :: * -> *) a.
Derivable repr =>
repr a -> Derived repr a
derive Data able View a
x :: View a)

data ViewEnv
  = ViewEnv
  { ViewEnv -> (Infix, Side)
viewEnv_op :: (Infix, Side)
  , ViewEnv -> Pair
viewEnv_pair :: Pair
  , ViewEnv -> Precedence
viewEnv_lamDepth :: Int
  }

pairView :: ViewEnv -> Infix -> ShowS -> ShowS
pairView :: ViewEnv -> Infix -> ShowS -> ShowS
pairView ViewEnv
env Infix
op ShowS
s =
  if (Infix, Side) -> Infix -> Bool
isPairNeeded (ViewEnv -> (Infix, Side)
viewEnv_op ViewEnv
env) Infix
op
  then String -> ShowS
showString String
o ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
c
  else ShowS
s
  where (String
o,String
c) = ViewEnv -> Pair
viewEnv_pair ViewEnv
env

instance Abstractable View where
  var :: View a -> View a
var = View a -> View a
forall a. a -> a
Fun.id
  lam :: (View a -> View b) -> View (a -> b)
lam View a -> View b
f = String -> (View a -> View b) -> View (a -> b)
forall a b. String -> (View a -> View b) -> View (a -> b)
viewLam String
"x" View a -> View b
f
  lam1 :: (View a -> View b) -> View (a -> b)
lam1 View a -> View b
f = String -> (View a -> View b) -> View (a -> b)
forall a b. String -> (View a -> View b) -> View (a -> b)
viewLam String
"u" View a -> View b
f
  ViewInfix Infix
op String
_name String
infixName .@ :: View (a -> b) -> View a -> View b
.@ ViewApp View (b -> a)
x View b
y = (ViewEnv -> ShowS) -> View b
forall a. (ViewEnv -> ShowS) -> View a
View ((ViewEnv -> ShowS) -> View b) -> (ViewEnv -> ShowS) -> View b
forall a b. (a -> b) -> a -> b
Fun.$ \ViewEnv
env ->
    ViewEnv -> Infix -> ShowS -> ShowS
pairView ViewEnv
env Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
      View (b -> a) -> ViewEnv -> ShowS
forall a. View a -> ViewEnv -> ShowS
runView View (b -> a)
x ViewEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op=(Infix
op, Side
SideL)} ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
      String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
infixName ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
      View b -> ViewEnv -> ShowS
forall a. View a -> ViewEnv -> ShowS
runView View b
y ViewEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op=(Infix
op, Side
SideR)}
  ViewInfix Infix
op String
name String
_infixName .@ View a
x = (ViewEnv -> ShowS) -> View b
forall a. (ViewEnv -> ShowS) -> View a
View ((ViewEnv -> ShowS) -> View b) -> (ViewEnv -> ShowS) -> View b
forall a b. (a -> b) -> a -> b
Fun.$ \ViewEnv
env ->
    Bool -> ShowS -> ShowS
showParen Bool
Prelude.True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
      View a -> ViewEnv -> ShowS
forall a. View a -> ViewEnv -> ShowS
runView View a
x ViewEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op=(Infix
op, Side
SideL)} ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
      String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
name
  View (a -> b)
f .@ View a
x = View (a -> b) -> View a -> View b
forall a b. View (a -> b) -> View a -> View b
ViewApp View (a -> b)
f View a
x
viewLam :: String -> (View a -> View b) -> View (a -> b)
viewLam :: String -> (View a -> View b) -> View (a -> b)
viewLam String
varPrefix View a -> View b
f = (ViewEnv -> ShowS) -> View (a -> b)
forall a. (ViewEnv -> ShowS) -> View a
View ((ViewEnv -> ShowS) -> View (a -> b))
-> (ViewEnv -> ShowS) -> View (a -> b)
forall a b. (a -> b) -> a -> b
Fun.$ \ViewEnv
env ->
  ViewEnv -> Infix -> ShowS -> ShowS
pairView ViewEnv
env Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
    let x :: ShowS
x = String -> ShowS
showString String
varPrefix ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
            Precedence -> Precedence -> ShowS
forall a. Show a => Precedence -> a -> ShowS
showsPrec Precedence
0 (ViewEnv -> Precedence
viewEnv_lamDepth ViewEnv
env) in
    -- showString "Lam1 (" .
    String -> ShowS
showString String
"\\" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. ShowS
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
" -> " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun..
    View b -> ViewEnv -> ShowS
forall a. View a -> ViewEnv -> ShowS
runView (View a -> View b
f ((ViewEnv -> ShowS) -> View a
forall a. (ViewEnv -> ShowS) -> View a
View (\ViewEnv
_env -> ShowS
x))) ViewEnv
env
      { viewEnv_op :: (Infix, Side)
viewEnv_op = (Infix
op, Side
SideL)
      , viewEnv_lamDepth :: Precedence
viewEnv_lamDepth = Precedence -> Precedence
forall a. Enum a => a -> a
Prelude.succ (ViewEnv -> Precedence
viewEnv_lamDepth ViewEnv
env)
      }
    -- . showString ")"
  where
  op :: Infix
op = Precedence -> Infix
infixN Precedence
0
instance Anythingable View
instance Bottomable View where
  bottom :: View a
bottom = View a
"<hidden>"
instance Show c => Constantable c View where
  constant :: c -> View c
constant c
c = (ViewEnv -> ShowS) -> View c
forall a. (ViewEnv -> ShowS) -> View a
View ((ViewEnv -> ShowS) -> View c) -> (ViewEnv -> ShowS) -> View c
forall a b. (a -> b) -> a -> b
Fun.$ \ViewEnv
_env -> c -> ShowS
forall a. Show a => a -> ShowS
shows c
c
instance Eitherable View where
  left :: View (l -> Either l r)
left = View (l -> Either l r)
"Left"
  right :: View (r -> Either l r)
right = View (r -> Either l r)
"Right"
instance Equalable View where
  equal :: View (a -> a -> Bool)
equal = Infix -> String -> String -> View (a -> a -> Bool)
forall a b c. Infix -> String -> String -> View (a -> b -> c)
ViewInfix (Precedence -> Infix
infixN Precedence
4) String
"(==)" String
"=="
instance Listable View where
  cons :: View (a -> [a] -> [a])
cons = Infix -> String -> String -> View (a -> [a] -> [a])
forall a b c. Infix -> String -> String -> View (a -> b -> c)
ViewInfix (Precedence -> Infix
infixR Precedence
5) String
"(:)" String
":"
  nil :: View [a]
nil = View [a]
"[]"
instance Maybeable View where
  nothing :: View (Maybe a)
nothing = View (Maybe a)
"Nothing"
  just :: View (a -> Maybe a)
just = View (a -> Maybe a)
"Just"