@@ -0,0 +1,106 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Declaration where
3+
4+import Data.Binary
5+import qualified AST.Expression.Source as Source
6+import qualified AST.Expression.Valid as Valid
7+import qualified AST.Expression.Canonical as Canonical
8+import qualified AST.Type as T
9+import qualified AST.Variable as Var
10+import AST.PrettyPrint
11+import Text.PrettyPrint as P
12+
13+data Declaration' port def var
14+ = Definition def
15+ | Datatype String [String] [(String, [T.Type var])]
16+ | TypeAlias String [String] (T.Type var)
17+ | Port port
18+ | Fixity Assoc Int String
19+ deriving (Show)
20+
21+data Assoc = L | N | R
22+ deriving (Eq)
23+
24+data RawPort
25+ = PPAnnotation String (T.Type Var.Raw)
26+ | PPDef String Source.Expr
27+ deriving (Show)
28+
29+data Port expr var
30+ = Out String expr (T.Type var)
31+ | In String (T.Type var)
32+ deriving (Show)
33+
34+type SourceDecl = Declaration' RawPort Source.Def Var.Raw
35+type ValidDecl = Declaration' (Port Valid.Expr Var.Raw) Valid.Def Var.Raw
36+type CanonicalDecl = Declaration' (Port Canonical.Expr Var.Canonical)
37+ Canonical.Def
38+ Var.Canonical
39+
40+portName :: Port expr var -> String
41+portName port =
42+ case port of
43+ Out name _ _ -> name
44+ In name _ -> name
45+
46+instance Show Assoc where
47+ show assoc =
48+ case assoc of
49+ L -> "left"
50+ N -> "non"
51+ R -> "right"
52+
53+instance Binary Assoc where
54+ get = do n <- getWord8
55+ return $ case n of
56+ 0 -> L
57+ 1 -> N
58+ 2 -> R
59+ _ -> error "Error reading valid associativity from serialized string"
60+
61+ put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }
62+
63+instance (Pretty port, Pretty def, Pretty var, Var.ToString var) =>
64+ Pretty (Declaration' port def var) where
65+ pretty decl =
66+ case decl of
67+ Definition def -> pretty def
68+
69+ Datatype tipe tvars ctors ->
70+ P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4
71+ (P.sep $ zipWith join ("=" : repeat "|") ctors)
72+ where
73+ join c ctor = P.text c <+> prettyCtor ctor
74+ prettyCtor (name, tipes) =
75+ P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))
76+
77+ TypeAlias name tvars tipe ->
78+ P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)
79+ where
80+ name' = P.text name <+> P.hsep (map P.text tvars)
81+
82+ Port port -> pretty port
83+
84+ Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op
85+ where
86+ assoc' = case assoc of
87+ L -> P.text "l"
88+ N -> P.empty
89+ R -> P.text "r"
90+
91+instance Pretty RawPort where
92+ pretty port =
93+ case port of
94+ PPAnnotation name tipe -> prettyPort name ":" tipe
95+ PPDef name expr -> prettyPort name "=" expr
96+
97+instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Port expr var) where
98+ pretty port =
99+ case port of
100+ In name tipe -> prettyPort name ":" tipe
101+ Out name expr tipe -> P.vcat [ prettyPort name ":" tipe
102+ , prettyPort name "=" expr ]
103+
104+
105+prettyPort :: (Pretty a) => String -> String -> a -> Doc
106+prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e