git.iko.soy/elk
on df135b8 help sign in
elk/compiler/SourceSyntax/Declaration.hs
122 lines 3.8 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 | PPDef String Expr.LParseExpr
27 deriving (Show)
29data Port
30 = Out String Expr.LExpr T.Type
31 | In String T.Type
32 deriving (Show)
34type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
35type Declaration = Declaration' Port Expr.Def
37instance Binary Derivation where
38 get = do n <- getWord8
39 return $ case n of
40 0 -> Json
41 1 -> JS
42 2 -> Binary
43 3 -> New
44 _ -> error "Unable to decode Derivation. You may have corrupted binary files,\n\
45 \so please report an issue at <https://github.com/evancz/Elm/issues>"
47 put derivation =
48 putWord8 $ case derivation of
49 Json -> 0
50 JS -> 1
51 Binary -> 2
52 New -> 3
54instance Show Assoc where
55 show assoc =
56 case assoc of
57 L -> "left"
58 N -> "non"
59 R -> "right"
61instance Binary Assoc where
62 get = do n <- getWord8
63 return $ case n of
64 0 -> L
65 1 -> N
66 2 -> R
67 _ -> error "Error reading valid associativity from serialized string"
69 put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }
71instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where
72 pretty decl =
73 case decl of
74 Definition def -> pretty def
76 Datatype tipe tvars ctors deriveables ->
77 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4
78 (P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables
79 where
80 join c ctor = P.text c <+> prettyCtor ctor
81 prettyCtor (name, tipes) =
82 P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))
84 TypeAlias name tvars tipe deriveables ->
85 alias <+> prettyDeriving deriveables
86 where
87 name' = P.text name <+> P.hsep (map P.text tvars)
88 alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)
90 Port port -> pretty port
92 Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op
93 where
94 assoc' = case assoc of
95 L -> P.text "l"
96 N -> P.empty
97 R -> P.text "r"
99instance Pretty ParsePort where
100 pretty port =
101 case port of
102 PPAnnotation name tipe -> prettyPort name ":" tipe
103 PPDef name expr -> prettyPort name "=" expr
105instance Pretty Port where
106 pretty port =
107 case port of
108 In name tipe -> prettyPort name ":" tipe
109 Out name expr tipe -> P.vcat [ prettyPort name ":" tipe
110 , prettyPort name "=" expr ]
113prettyPort :: (Pretty a) => String -> String -> a -> Doc
114prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e
116prettyDeriving :: [Derivation] -> Doc
117prettyDeriving deriveables =
118 case deriveables of
119 [] -> P.empty
120 [d] -> P.text "deriving" <+> P.text (show d)
121 ds -> P.text "deriving" <+>
122 P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)