git.iko.soy/elk
on 552becc help sign in
elk/src/AST/Declaration.hs
202 lines 4.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module AST.Declaration where
4import Data.Binary
5import qualified AST.Expression.Source as Source
6import qualified AST.Expression.Valid as Valid
7import qualified AST.Expression.Canonical as Canonical
8import qualified AST.Type as T
9import qualified AST.Variable as Var
10import AST.PrettyPrint
11import Text.PrettyPrint as P
14-- DECLARATIONS
16data Declaration' wire def var
17 = Definition def
18 | Datatype String [String] [(String, [T.Type var])]
19 | TypeAlias String [String] (T.Type var)
20 | Wire wire
21 | Fixity Assoc Int String
24data Assoc = L | N | R
25 deriving (Eq)
28-- DECLARATION PHASES
30type SourceDecl =
31 Declaration' RawWire Source.Def Var.Raw
34type ValidDecl =
35 Declaration' ValidWire Valid.Def Var.Raw
38type CanonicalDecl =
39 Declaration' CanonicalWire Canonical.Def Var.Canonical
42-- WIRES
44data RawWire
45 = InputAnnotation String T.RawType
46 | OutputAnnotation String T.RawType
47 | OutputDefinition String Source.Expr
48 | LoopbackAnnotation String T.RawType
49 | LoopbackDefinition String Source.Expr
52data Wire expr var input
53 = Input String (T.Type var)
54 | Output String expr (T.Type var)
55 | Loopback input
58data ValidLoopback =
59 ValidLoopback String (Maybe Valid.Expr) T.RawType
62data CanonicalLoopback
63 = Address String T.CanonicalType
64 | Promise String T.CanonicalType Canonical.Expr T.CanonicalType
67type ValidWire =
68 Wire Valid.Expr Var.Raw ValidLoopback
71type CanonicalWire =
72 Wire Canonical.Expr Var.Canonical CanonicalLoopback
75-- BINARY CONVERSION
77instance Binary Assoc where
78 get =
79 do n <- getWord8
80 return $ case n of
81 0 -> L
82 1 -> N
83 2 -> R
84 _ -> error "Error reading valid associativity from serialized string"
86 put assoc =
87 putWord8 $
88 case assoc of
89 L -> 0
90 N -> 1
91 R -> 2
94-- PRETTY STRINGS
96assocToString :: Assoc -> String
97assocToString assoc =
98 case assoc of
99 L -> "left"
100 N -> "non"
101 R -> "right"
104instance (Pretty wire, Pretty def, Pretty var, Var.ToString var) =>
105 Pretty (Declaration' wire def var) where
106 pretty decl =
107 case decl of
108 Definition def -> pretty def
110 Datatype tipe tvars ctors ->
111 P.hang
112 (P.text "type" <+> P.text tipe <+> P.hsep (map P.text tvars))
113 4
114 (P.sep $ zipWith (<+>) seperators (map prettyCtor ctors))
115 where
116 seperators =
117 map P.text ("=" : repeat "|")
119 prettyCtor (name, tipes) =
120 P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))
122 TypeAlias name tvars tipe ->
123 P.hang
124 (P.text "type" <+> P.text "alias" <+> name' <+> P.equals)
125 4
126 (pretty tipe)
127 where
128 name' =
129 P.text name <+> P.hsep (map P.text tvars)
131 Wire wire -> pretty wire
133 Fixity assoc prec op ->
134 P.text "infix" <> assoc' <+> P.int prec <+> P.text op
135 where
136 assoc' =
137 case assoc of
138 L -> P.text "l"
139 N -> P.empty
140 R -> P.text "r"
143instance Pretty RawWire where
144 pretty wire =
145 case wire of
146 InputAnnotation name tipe ->
147 prettyWire "foreign input" name ":" tipe
149 OutputAnnotation name tipe ->
150 prettyWire "foreign output" name ":" tipe
152 OutputDefinition name expr ->
153 prettyWire "foreign output" name "=" expr
155 LoopbackAnnotation name tipe ->
156 prettyWire "input" name ":" tipe
158 LoopbackDefinition name expr ->
159 prettyWire "input" name "from" expr
162instance (Pretty expr, Pretty var, Var.ToString var, Pretty input) =>
163 Pretty (Wire expr var input) where
164 pretty wire =
165 case wire of
166 Input name tipe ->
167 prettyWire "foreign input" name ":" tipe
169 Output name expr tipe ->
170 P.vcat
171 [ prettyWire "foreign output" name ":" tipe
172 , prettyWire "foreign output" name "=" expr
173 ]
175 Loopback input ->
176 pretty input
179instance Pretty ValidLoopback where
180 pretty (ValidLoopback name maybeExpr tipe) =
181 P.vcat
182 [ prettyWire "input" name ":" tipe
183 , maybe P.empty (prettyWire "input" name "<-") maybeExpr
184 ]
187instance Pretty CanonicalLoopback where
188 pretty input =
189 case input of
190 Address name tipe ->
191 prettyWire "input" name ":" tipe
193 Promise name _promiseType expr resultType ->
194 P.vcat
195 [ prettyWire "input" name ":" resultType
196 , prettyWire "input" name "<-" expr
197 ]
200prettyWire :: (Pretty a) => String -> String -> String -> a -> Doc
201prettyWire keyword name op e =
202 P.text keyword <+> P.text name <+> P.text op <+> pretty e