git.iko.soy/elk
on d92ac79 help sign in
elk/compiler/SourceSyntax/Declaration.hs
129 lines 4.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module SourceSyntax.Declaration where
4import Data.Binary
5import qualified SourceSyntax.Expression as Expr
6import qualified SourceSyntax.Type as T
7import SourceSyntax.PrettyPrint
8import Text.PrettyPrint as P
10data Declaration' port def
11 = Definition def
12 | Datatype String [String] [(String,[T.Type])] [Derivation]
13 | TypeAlias String [String] T.Type [Derivation]
14 | Port port
15 | Fixity Assoc Int String
16 deriving (Show)
18data Assoc = L | N | R
19 deriving (Eq)
21data Derivation = Json | JS | Binary | New
22 deriving (Eq, Show)
24data ParsePort
25 = PPAnnotation String T.Type
26 | PPOut String Expr.LParseExpr
27 | PPIn String Expr.LParseExpr
28 deriving (Show)
30data Port
31 = Out String Expr.LExpr T.Type
32 | In String (Maybe Expr.LExpr) T.Type
33 deriving (Show)
35type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
36type Declaration = Declaration' Port Expr.Def
38instance Binary Derivation where
39 get = do n <- getWord8
40 return $ case n of
41 0 -> Json
42 1 -> JS
43 2 -> Binary
44 3 -> New
45 _ -> error "Unable to decode Derivation. You may have corrupted binary files,\n\
46 \so please report an issue at <https://github.com/evancz/Elm/issues>"
48 put derivation =
49 putWord8 $ case derivation of
50 Json -> 0
51 JS -> 1
52 Binary -> 2
53 New -> 3
55instance Show Assoc where
56 show assoc =
57 case assoc of
58 L -> "left"
59 N -> "non"
60 R -> "right"
62instance Binary Assoc where
63 get = do n <- getWord8
64 return $ case n of
65 0 -> L
66 1 -> N
67 2 -> R
68 _ -> error "Error reading valid associativity from serialized string"
70 put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }
72instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where
73 pretty decl =
74 case decl of
75 Definition def -> pretty def
77 Datatype tipe tvars ctors deriveables ->
78 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4
79 (P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables
80 where
81 join c ctor = P.text c <+> prettyCtor ctor
82 prettyCtor (name, tipes) =
83 P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))
85 TypeAlias name tvars tipe deriveables ->
86 alias <+> prettyDeriving deriveables
87 where
88 name' = P.text name <+> P.hsep (map P.text tvars)
89 alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)
91 Port port -> pretty port
93 Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op
94 where
95 assoc' = case assoc of
96 L -> P.text "l"
97 N -> P.empty
98 R -> P.text "r"
100instance Pretty ParsePort where
101 pretty port =
102 case port of
103 PPAnnotation name tipe -> prettyPort name ":" tipe
104 PPOut name expr -> prettyPort name "<-" expr
105 PPIn name expr -> prettyPort name "->" expr
107instance Pretty Port where
108 pretty port =
109 case port of
110 Out name expr tipe -> mkPort "<-" name expr tipe
111 In name mexpr tipe ->
112 case mexpr of
113 Nothing -> prettyPort name ":" tipe
114 Just expr -> mkPort "->" name expr tipe
115 where
116 mkPort arrow name expr tipe =
117 P.vcat [ prettyPort name ":" tipe
118 , prettyPort name arrow expr ]
120prettyPort :: (Pretty a) => String -> String -> a -> Doc
121prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e
123prettyDeriving :: [Derivation] -> Doc
124prettyDeriving deriveables =
125 case deriveables of
126 [] -> P.empty
127 [d] -> P.text "deriving" <+> P.text (show d)
128 ds -> P.text "deriving" <+>
129 P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)