]> 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 (fun:: * -> *) 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 fun h -> String
29 string_from_expr r = unRepr_String r precedence_Toplevel 0
30
31 instance Show (Repr_String fun a) where
32 show = string_from_expr
33
34 instance Sym_Lambda fun (Repr_String fun) where
35 type Lambda_from_Repr (Repr_String fun) = fun
36 app (Repr_String f) (Repr_String x) = Repr_String $ \p v ->
37 let p' = precedence_App in
38 paren p p' $
39 f p' v <> " " <> x p' v
40 inline = repr_string_fun "!"
41 val = repr_string_fun ""
42 lazy = repr_string_fun "~"
43
44 let_inline = repr_string_let "!"
45 let_val = repr_string_let ""
46 let_lazy = repr_string_let "~"
47
48 -- ** Helpers for 'Sym_Lambda' instances
49 repr_string_fun :: String -> (Repr_String fun a2 -> Repr_String fun a1) -> Repr_String fun a
50 repr_string_fun mode e =
51 Repr_String $ \p v ->
52 let p' = precedence_Lambda in
53 let x = "x" <> show v in
54 paren p p' $
55 "\\" <> mode <> x <> " -> " <>
56 unRepr_String (e (Repr_String $ \_p _v -> x)) p' (succ v)
57 repr_string_let
58 :: String
59 -> Repr_String fun a1
60 -> (Repr_String fun a3 -> Repr_String fun a2)
61 -> Repr_String fun a
62 repr_string_let mode e in_ =
63 Repr_String $ \p v ->
64 let p' = precedence_Let in
65 let x = "x" <> show v in
66 paren p p' $
67 "let" <> mode <> " " <> x <> " = " <> unRepr_String e p (succ v) <> " in " <>
68 unRepr_String (in_ (Repr_String $ \_p _v -> x)) p (succ v)
69
70 instance Sym_Bool (Repr_String fun) where
71 bool a = Repr_String $ \_p _v -> 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 fun) where
90 int a = Repr_String $ \_p _v -> show a
91 neg (Repr_String x) =
92 Repr_String $ \p v ->
93 let p' = precedence_Neg in
94 paren p p' $ "-" <> x (precedence_succ p') v
95 add (Repr_String x) (Repr_String y) =
96 Repr_String $ \p v ->
97 let p' = precedence_Add in
98 paren p p' $ x p' v <> " + " <> y p' v
99 {-
100 instance Sym_If Repr_String where
101 if_
102 (Repr_String cond)
103 (Repr_String ok)
104 (Repr_String ko) =
105 Repr_String $ \p v ->
106 let p' = precedence_If in
107 paren p p' $
108 "if " <> cond p' v <>
109 " then " <> ok p' v <>
110 " else " <> ko p' v
111 when_ (Repr_String cond) (Repr_String ok) =
112 Repr_String $ \p v ->
113 let p' = precedence_If in
114 paren p p' $
115 "when " <> cond p' v <>
116 " " <> ok p' v
117 -}
118
119 -- ** Type 'Precedence'
120
121 newtype Precedence = Precedence Int
122 deriving (Eq, Ord, Show)
123 precedence_pred :: Precedence -> Precedence
124 precedence_pred (Precedence p) = Precedence (pred p)
125 precedence_succ :: Precedence -> Precedence
126 precedence_succ (Precedence p) = Precedence (succ p)
127 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
128 paren prec prec' x =
129 if prec >= prec'
130 then fromString "(" <> x <> fromString ")"
131 else x
132
133 precedence_Toplevel :: Precedence
134 precedence_Toplevel = Precedence 0
135 precedence_Lambda :: Precedence
136 precedence_Lambda = Precedence 1
137 precedence_Let :: Precedence
138 precedence_Let = Precedence 2
139 precedence_If :: Precedence
140 precedence_If = Precedence 3
141 precedence_Or :: Precedence
142 precedence_Or = Precedence 4
143 precedence_Add :: Precedence
144 precedence_Add = precedence_Or
145 precedence_Xor :: Precedence
146 precedence_Xor = Precedence 5
147 precedence_And :: Precedence
148 precedence_And = Precedence 6
149 precedence_App :: Precedence
150 precedence_App = Precedence 7
151 precedence_Not :: Precedence
152 precedence_Not = Precedence 8
153 precedence_Neg :: Precedence
154 precedence_Neg = precedence_Not
155 precedence_Atomic :: Precedence
156 precedence_Atomic = Precedence 9