git.iko.soy/elk
on 09d86de help sign in
elk/src/Transform/Expression.hs
115 lines 3.3 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 expression =
44 go expression
45 where
46 go (A srcSpan expr) =
47 A srcSpan <$>
48 case expr of
49 Var x ->
50 return (Var x)
52 Lambda p e ->
53 Lambda p <$> go e
55 Binop op e1 e2 ->
56 Binop op <$> go e1 <*> go e2
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 e1 e2 ->
68 Range <$> go e1 <*> go e2
70 ExplicitList es ->
71 ExplicitList <$> mapM go es
73 App e1 e2 ->
74 App <$> go e1 <*> go e2
76 MultiIf branches ->
77 MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches
79 Access e lbl ->
80 Access <$> go e <*> return lbl
82 Remove e lbl ->
83 Remove <$> go e <*> return lbl
85 Insert e lbl v ->
86 Insert <$> go e <*> return lbl <*> go v
88 Modify e fields ->
89 Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields
91 Record fields ->
92 Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
94 Let defs body ->
95 Let <$> defsTransform defs <*> go body
97 GLShader uid src gltipe ->
98 return $ GLShader uid src gltipe
100 Input name st ->
101 do inputCheck name st
102 return $ Input name st
104 Output name st signal ->
105 do outputCheck name st
106 Output name st <$> go signal
108 Loopback name st maybeExpr ->
109 do let hasExpr = maybe False (const True) maybeExpr
110 loopbackCheck name st hasExpr
111 case maybeExpr of
112 Nothing ->
113 return (Loopback name st Nothing)
114 Just expr ->
115 (Loopback name st . Just) <$> go expr