]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Repr/Text.hs
init
[haskell/symantic.git] / Language / Symantic / Repr / Text.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE TypeFamilies #-}
6 -- | Interpreter to serialize an expression into a 'Text'.
7 module Language.Symantic.Repr.Text where
8
9 import Data.Monoid ((<>))
10 import Data.String (IsString(..))
11 import Data.Text (Text)
12 import qualified Data.Text as Text
13
14 import Language.Symantic.Expr
15
16 -- * Type 'Repr_Text'
17
18 -- | Interpreter's data.
19 newtype Repr_Text (lam:: * -> *) h
20 = Repr_Text
21 { unRepr_Text
22 -- Inherited attributes:
23 :: Precedence
24 -> Repr_Text_Lambda_Depth
25 -- Synthetised attributes:
26 -> Text
27 }
28 type Repr_Text_Lambda_Depth = Int
29
30 -- | Interpreter.
31 text_from_expr :: Repr_Text lam h -> Text
32 text_from_expr r = unRepr_Text r precedence_Toplevel 0
33
34 {-
35 instance Show (Repr_Text lam a) where
36 show = text_from_expr
37 -}
38 instance Sym_Lambda lam (Repr_Text lam) where
39 type Lambda_from_Repr (Repr_Text lam) = lam
40 app (Repr_Text f) (Repr_Text x) = Repr_Text $ \p v ->
41 let p' = precedence_App in
42 paren p p' $
43 f p' v <> " " <> x p' v
44 inline = repr_text_fun "!"
45 val = repr_text_fun ""
46 lazy = repr_text_fun "~"
47
48 let_inline = repr_text_let "!"
49 let_val = repr_text_let ""
50 let_lazy = repr_text_let "~"
51
52 -- ** Helpers for 'Sym_Lambda' instances
53 repr_text_fun :: Text -> (Repr_Text lam a2 -> Repr_Text lam a1) -> Repr_Text lam a
54 repr_text_fun mode e =
55 Repr_Text $ \p v ->
56 let p' = precedence_Lambda in
57 let x = "x" <> Text.pack (show v) in
58 paren p p' $
59 "\\" <> mode <> x <> " -> " <>
60 unRepr_Text (e (Repr_Text $ \_p _v -> x)) p' (succ v)
61 repr_text_let
62 :: Text
63 -> Repr_Text lam a1
64 -> (Repr_Text lam a3 -> Repr_Text lam a2)
65 -> Repr_Text lam a
66 repr_text_let mode e in_ =
67 Repr_Text $ \p v ->
68 let p' = precedence_Let in
69 let x = "x" <> Text.pack (show v) in
70 paren p p' $
71 "let" <> mode <> " " <> x <> " = " <> unRepr_Text e p (succ v) <> " in " <>
72 unRepr_Text (in_ (Repr_Text $ \_p _v -> x)) p (succ v)
73
74 instance Sym_Bool (Repr_Text lam) where
75 bool a = Repr_Text $ \_p _v ->
76 Text.pack (show a)
77 not (Repr_Text x) =
78 Repr_Text $ \p v ->
79 let p' = precedence_Not in
80 paren p p' $ "!" <> x p' v
81 and (Repr_Text x) (Repr_Text y) =
82 Repr_Text $ \p v ->
83 let p' = precedence_And in
84 paren p p' $ x p' v <> " & " <> y p' v
85 or (Repr_Text x) (Repr_Text y) =
86 Repr_Text $ \p v ->
87 let p' = precedence_Or in
88 paren p p' $ x p' v <> " | " <> y p' v
89 {-xor (Repr_Text x) (Repr_Text y) =
90 Repr_Text $ \p v ->
91 let p' = precedence_Xor in
92 paren p p' $ x p' v <> " * " <> y p' v
93 -}
94 instance Sym_Int (Repr_Text lam) where
95 int a = Repr_Text $ \_p _v ->
96 Text.pack (show a)
97 neg (Repr_Text x) =
98 Repr_Text $ \p v ->
99 let p' = precedence_Neg in
100 paren p p' $ "-" <> x p' v
101 add (Repr_Text x) (Repr_Text y) =
102 Repr_Text $ \p v ->
103 let p' = precedence_Add in
104 paren p p' $ x p' v <> " + " <> y p' v
105 instance Sym_Maybe lam (Repr_Text lam) where
106 maybe (Repr_Text n) (Repr_Text j) (Repr_Text m) =
107 Repr_Text $ \p v ->
108 let p' = precedence_App in
109 paren p p' $ "maybe"
110 <> " " <> n p' v
111 <> " " <> j p' v
112 <> " " <> m p' v
113 instance Sym_Maybe_Cons (Repr_Text lam) where
114 nothing =
115 Repr_Text $ \_p _v ->
116 "nothing"
117 just (Repr_Text a) =
118 Repr_Text $ \p v ->
119 let p' = precedence_App in
120 paren p p' $ "just "
121 <> a (p') v
122 instance Sym_If (Repr_Text lam) where
123 if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) =
124 Repr_Text $ \p v ->
125 let p' = precedence_If in
126 paren p p' $
127 "if " <> cond p' v <>
128 " then " <> ok p' v <>
129 " else " <> ko p' v
130 instance Sym_When (Repr_Text lam) where
131 when (Repr_Text cond) (Repr_Text ok) =
132 Repr_Text $ \p v ->
133 let p' = precedence_If in
134 paren p p' $
135 "when " <> cond p' v <>
136 " " <> ok p' v
137 instance Sym_Eq (Repr_Text lam) where
138 eq (Repr_Text x) (Repr_Text y) =
139 Repr_Text $ \p v ->
140 let p' = precedence_Eq in
141 paren p p' $
142 x p' v <> " == " <> y p' v
143
144 -- ** Type 'Precedence'
145
146 newtype Precedence = Precedence Int
147 deriving (Eq, Ord, Show)
148 precedence_pred :: Precedence -> Precedence
149 precedence_pred (Precedence p) = Precedence (pred p)
150 precedence_succ :: Precedence -> Precedence
151 precedence_succ (Precedence p) = Precedence (succ p)
152 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
153 paren prec prec' x =
154 if prec >= prec'
155 then fromString "(" <> x <> fromString ")"
156 else x
157
158 precedence_Toplevel :: Precedence
159 precedence_Toplevel = Precedence 0
160 precedence_Lambda :: Precedence
161 precedence_Lambda = Precedence 1
162 precedence_If :: Precedence
163 precedence_If = Precedence 2
164 precedence_Let :: Precedence
165 precedence_Let = Precedence 3
166 precedence_Eq :: Precedence
167 precedence_Eq = Precedence 4
168 precedence_Or :: Precedence
169 precedence_Or = Precedence 5
170 precedence_Xor :: Precedence
171 precedence_Xor = Precedence 6
172 precedence_And :: Precedence
173 precedence_And = Precedence 7
174 precedence_Add :: Precedence
175 precedence_Add = precedence_And
176 precedence_App :: Precedence
177 precedence_App = Precedence 8
178 precedence_Not :: Precedence
179 precedence_Not = Precedence 9
180 precedence_Neg :: Precedence
181 precedence_Neg = precedence_Not
182 precedence_Atomic :: Precedence
183 precedence_Atomic = Precedence maxBound