git.iko.soy/elk
on 501c607 help sign in
elk/src/Transform/Expression.hs
117 lines 3.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Expression (crawlLet, checkWires) where
4import Control.Applicative ((<$>),(<*>))
5import AST.Annotation ( Annotated(A) )
6import AST.Expression.General
7import qualified AST.Expression.Canonical as Canonical
8import AST.Type (Type, CanonicalType)
11crawlLet
12 :: ([def] -> Either a [def'])
13 -> Expr ann def var
14 -> Either a (Expr ann def' var)
15crawlLet =
16 crawl
17 (\_ _ -> return ())
18 (\_ _ -> return ())
19 (\_ _ _ -> return ())
22checkWires
23 :: (String -> CanonicalType -> Either a ())
24 -> (String -> CanonicalType -> Either a ())
25 -> (String -> CanonicalType -> Bool -> Either a ())
26 -> Canonical.Expr
27 -> Either a Canonical.Expr
28checkWires inputCheck outputCheck loopbackCheck expr =
29 crawl inputCheck outputCheck loopbackCheck (mapM checkDef) expr
30 where
31 checkDef def@(Canonical.Definition _ body _) =
32 do _ <- checkWires inputCheck outputCheck loopbackCheck body
33 return def
36crawl
37 :: (String -> Type var -> Either a ())
38 -> (String -> Type var -> Either a ())
39 -> (String -> Type var -> Bool -> Either a ())
40 -> ([def] -> Either a [def'])
41 -> Expr ann def var
42 -> Either a (Expr ann def' var)
43crawl inputCheck outputCheck loopbackCheck defsTransform annotatedExpression =
44 go annotatedExpression
45 where
46 go (A srcSpan expression) =
47 A srcSpan <$>
48 case expression of
49 Var x ->
50 return (Var x)
52 Lambda pattern body ->
53 Lambda pattern <$> go body
55 Binop op leftExpr rightExpr ->
56 Binop op <$> go leftExpr <*> go rightExpr
58 Case e cases ->
59 Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases
61 Data name es ->
62 Data name <$> mapM go es
64 Literal lit ->
65 return (Literal lit)
67 Range lowExpr highExpr ->
68 Range <$> go lowExpr <*> go highExpr
70 ExplicitList expressions ->
71 ExplicitList <$> mapM go expressions
73 App funcExpr argExpr ->
74 App <$> go funcExpr <*> go argExpr
76 MultiIf branches ->
77 MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches
79 Access record field ->
80 Access <$> go record <*> return field
82 Remove record field ->
83 Remove <$> go record <*> return field
85 Insert record field expr ->
86 Insert <$> go record <*> return field <*> go expr
88 Modify record fields ->
89 Modify
90 <$> go record
91 <*> mapM (\(field,expr) -> (,) field <$> go expr) fields
93 Record fields ->
94 Record <$> mapM (\(field,expr) -> (,) field <$> go expr) fields
96 Let defs body ->
97 Let <$> defsTransform defs <*> go body
99 GLShader uid src gltipe ->
100 return $ GLShader uid src gltipe
102 Input name st ->
103 do inputCheck name st
104 return $ Input name st
106 Output name st expr ->
107 do outputCheck name st
108 Output name st <$> go expr
110 Loopback name st maybeExpr ->
111 do let hasExpr = maybe False (const True) maybeExpr
112 loopbackCheck name st hasExpr
113 case maybeExpr of
114 Nothing ->
115 return (Loopback name st Nothing)
116 Just expr ->
117 (Loopback name st . Just) <$> go expr