git.iko.soy/elk
on cf07718 help sign in
elk/src/AST/Declaration.hs
172 lines 4.3 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
14data Declaration' wire def var
15 = Definition def
16 | Datatype String [String] [(String, [T.Type var])]
17 | TypeAlias String [String] (T.Type var)
18 | Wire wire
19 | Fixity Assoc Int String
22data Assoc = L | N | R
23 deriving (Eq)
26data RawWire
27 = InputAnnotation String T.RawType
28 | OutputAnnotation String T.RawType
29 | OutputDefinition String Source.Expr
30 | LoopbackAnnotation String T.RawType
31 | LoopbackDefinition String Source.Expr
34data Wire expr var
35 = Output String expr (T.Type var)
36 | Input String (T.Type var)
37 | Loopback String (Maybe expr) (T.Type var)
40type SourceDecl =
41 Declaration' RawWire Source.Def Var.Raw
44type ValidDecl =
45 Declaration' (Wire Valid.Expr Var.Raw) Valid.Def Var.Raw
48type CanonicalDecl =
49 Declaration' (Wire Canonical.Expr Var.Canonical) Canonical.Def Var.Canonical
52wireName :: Wire expr var -> String
53wireName wire =
54 case wire of
55 Input name _ -> name
56 Output name _ _ -> name
57 Loopback name _ _ -> name
60assocToString :: Assoc -> String
61assocToString assoc =
62 case assoc of
63 L -> "left"
64 N -> "non"
65 R -> "right"
68-- BINARY CONVERSION
70instance Binary Assoc where
71 get =
72 do n <- getWord8
73 return $ case n of
74 0 -> L
75 1 -> N
76 2 -> R
77 _ -> error "Error reading valid associativity from serialized string"
79 put assoc =
80 putWord8 $
81 case assoc of
82 L -> 0
83 N -> 1
84 R -> 2
87-- PRETTY STRINGS
89instance (Pretty wire, Pretty def, Pretty var, Var.ToString var) =>
90 Pretty (Declaration' wire def var) where
91 pretty decl =
92 case decl of
93 Definition def -> pretty def
95 Datatype tipe tvars ctors ->
96 P.hang
97 (P.text "type" <+> P.text tipe <+> P.hsep (map P.text tvars))
98 4
99 (P.sep $ zipWith (<+>) seperators (map prettyCtor ctors))
100 where
101 seperators =
102 map P.text ("=" : repeat "|")
104 prettyCtor (name, tipes) =
105 P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))
107 TypeAlias name tvars tipe ->
108 P.hang
109 (P.text "type" <+> P.text "alias" <+> name' <+> P.equals)
110 4
111 (pretty tipe)
112 where
113 name' =
114 P.text name <+> P.hsep (map P.text tvars)
116 Wire wire -> pretty wire
118 Fixity assoc prec op ->
119 P.text "infix" <> assoc' <+> P.int prec <+> P.text op
120 where
121 assoc' =
122 case assoc of
123 L -> P.text "l"
124 N -> P.empty
125 R -> P.text "r"
128instance Pretty RawWire where
129 pretty wire =
130 case wire of
131 InputAnnotation name tipe ->
132 prettyWire "input" name ":" tipe
134 OutputAnnotation name tipe ->
135 prettyWire "output" name ":" tipe
137 OutputDefinition name expr ->
138 prettyWire "output" name "=" expr
140 LoopbackAnnotation name tipe ->
141 prettyWire "loopback" name ":" tipe
143 LoopbackDefinition name expr ->
144 prettyWire "loopback" name "=" expr
147instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Wire expr var) where
148 pretty wire =
149 case wire of
150 Input name tipe ->
151 prettyWire "input" name ":" tipe
153 Output name expr tipe ->
154 P.vcat
155 [ prettyWire "output" name ":" tipe
156 , prettyWire "output" name "=" expr
157 ]
159 Loopback name maybeExpr tipe ->
160 P.vcat
161 [ prettyWire "loopback" name ":" tipe
162 , case maybeExpr of
163 Just expr ->
164 prettyWire "loopback" name "=" expr
165 Nothing ->
166 P.empty
167 ]
170prettyWire :: (Pretty a) => String -> String -> String -> a -> Doc
171prettyWire keyword name op e =
172 P.text keyword <+> P.text name <+> P.text op <+> pretty e