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