]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Haskell/View.hs
bug: a ref outside its def must be supported
[haskell/symantic-parser.git] / src / Symantic / Parser / Haskell / View.hs
1 {-# LANGUAGE DerivingStrategies #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE StandaloneDeriving #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5 module Symantic.Parser.Haskell.View where
6
7 import Data.Bool
8 import Data.Function (($), (.))
9 import Data.Int (Int)
10 import Data.Semigroup (Semigroup(..))
11 import Data.String (IsString(..), String)
12 import Prelude ((+))
13 import Text.Show (Show(..), ShowS, shows, showParen, showString)
14 import qualified Data.Function as Fun
15
16 import Symantic.Parser.Grammar.Fixity
17 import qualified Symantic.Parser.Haskell.Optimize as H
18
19 -- * Type 'ViewTerm'
20 newtype ViewTerm a = ViewTerm { unViewTerm ::
21 ViewTermInh -> ShowS }
22
23 instance IsString (ViewTerm a) where
24 fromString s = ViewTerm $ \_inh -> showString s
25
26 -- ** Type 'ViewTermInh'
27 data ViewTermInh
28 = ViewTermInh
29 { viewTermInh_op :: (Infix, Side)
30 , viewTermInh_pair :: Pair
31 , viewTermInh_lamDepth :: Int
32 }
33
34 pairViewTerm :: ViewTermInh -> Infix -> ShowS -> ShowS
35 pairViewTerm inh op s =
36 if isPairNeeded (viewTermInh_op inh) op
37 then showString o . s . showString c
38 else s
39 where (o,c) = viewTermInh_pair inh
40
41 instance Show (ViewTerm a) where
42 showsPrec p v = unViewTerm v ViewTermInh
43 { viewTermInh_op = (infixN p, SideL)
44 , viewTermInh_pair = pairParen
45 , viewTermInh_lamDepth = 1
46 }
47 instance Show (H.Term repr a) where
48 showsPrec p = showsPrec p . go
49 where
50 go :: forall b. H.Term repr b -> ViewTerm b
51 go = \case
52 H.Term{} -> "Term"
53 {-
54 (H.:.) H.:@ f H.:@ g -> ViewTerm $ \inh ->
55 pairViewTerm inh op Fun.$
56 unViewTerm (go f) inh{viewTermInh_op=op} Fun..
57 showString " . " Fun..
58 unViewTerm (go g) inh{viewTermInh_op=op}
59 where op = infixR 9
60 (H.:.) -> "(.)"
61 -}
62 {-
63 H.Char t -> ViewTerm $ \_inh ->
64 showString "(char " .
65 shows t .
66 showString ")"
67 -}
68 H.Char t -> ViewTerm $ \_inh -> shows t
69 H.Cons H.:@ x H.:@ xs -> ViewTerm $ \inh ->
70 pairViewTerm inh op Fun.$
71 unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
72 showString " : " Fun..
73 unViewTerm (go xs) inh{viewTermInh_op=(op, SideR)}
74 where op = infixN 5
75 H.Cons -> "cons"
76 H.Eq H.:@ x H.:@ y -> ViewTerm $ \inh ->
77 pairViewTerm inh op Fun.$
78 unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
79 showString " == " Fun..
80 unViewTerm (go y) inh{viewTermInh_op=(op, SideR)}
81 where op = infixN 4
82 H.Eq H.:@ x -> ViewTerm $ \inh ->
83 showParen True Fun.$
84 unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
85 showString " =="
86 where op = infixN 4
87 H.Eq -> "(==)"
88 H.Var v -> fromString v
89 H.Lam1 f -> viewLam "u" f
90 H.Lam f -> viewLam "x" f
91 f H.:@ x -> ViewTerm $ \inh ->
92 pairViewTerm inh op $
93 unViewTerm (go f) inh{viewTermInh_op = (op, SideL) } .
94 -- showString " :@ " .
95 showString " " .
96 unViewTerm (go x) inh{viewTermInh_op = (op, SideR) }
97 where op = infixN 10
98 {-
99 H.Const -> "const"
100 H.Flip -> "flip"
101 H.Id -> "id"
102 (H.:$) -> "($)"
103 -}
104 viewLam :: forall b c. String -> (H.Term repr b -> H.Term repr c) -> ViewTerm (b -> c)
105 viewLam v f = ViewTerm $ \inh ->
106 pairViewTerm inh op $
107 let x = v<>show (viewTermInh_lamDepth inh) in
108 -- showString "Lam1 (" .
109 showString "\\" . showString x . showString " -> " .
110 (unViewTerm (go (f (H.Var x))) inh
111 { viewTermInh_op = (op, SideL)
112 , viewTermInh_lamDepth = viewTermInh_lamDepth inh + 1
113 })
114 -- . showString ")"
115 where op = infixN 0