git.iko.soy/elk
on 6f75310 help sign in
elk/compiler/Transform/Declaration.hs
65 lines 2.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Declaration where
4import Control.Applicative ((<$>))
5import qualified SourceSyntax.Pattern as P
6import SourceSyntax.Expression as E
7import SourceSyntax.Declaration as D
9import qualified Transform.Expression as Expr
10import qualified Transform.Definition as Def
13combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]
14combineAnnotations = go
15 where
16 msg x = "Syntax Error: The type annotation for '" ++ x ++
17 "' must be directly above its definition."
19 go decls =
20 case decls of
21 -- simple cases, pass them through with no changes
22 [] -> return []
24 Datatype name tvars ctors ds : rest ->
25 (:) (Datatype name tvars ctors ds) <$> go rest
27 TypeAlias name tvars alias ds : rest ->
28 (:) (TypeAlias name tvars alias ds) <$> go rest
30 Fixity assoc prec op : rest ->
31 (:) (Fixity assoc prec op) <$> go rest
33 -- combine definitions
34 D.Definition def : defRest ->
35 case def of
36 Def pat expr ->
37 do expr' <- Expr.crawl Def.combineAnnotations expr
38 let def' = E.Definition pat expr' Nothing
39 (:) (D.Definition def') <$> go defRest
41 TypeAnnotation name tipe ->
42 case defRest of
43 D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
44 do expr' <- Expr.crawl Def.combineAnnotations expr
45 let def' = E.Definition pat expr' (Just tipe)
46 (:) (D.Definition def') <$> go rest
48 _ -> Left (msg name)
50 -- combine ports
51 Port port : portRest ->
52 case port of
53 SendDefinition name _ -> Left (msg name)
54 RecvDefinition name _ -> Left (msg name)
55 PortAnnotation name tipe ->
56 case portRest of
57 Port (SendDefinition name' expr) : rest | name == name' ->
58 do expr' <- Expr.crawl Def.combineAnnotations expr
59 (:) (Port (Send name expr' tipe)) <$> go rest
61 Port (RecvDefinition name' expr) : rest | name == name' ->
62 do expr' <- Expr.crawl Def.combineAnnotations expr
63 (:) (Port (Send name expr' tipe)) <$> go rest
65 _ -> Left (msg name)