git.iko.soy/elk
on 501c607 help sign in
elk/src/Transform/Canonicalize.hs
333 lines 11 kB history raw
1module Transform.Canonicalize (module') where
3import Control.Applicative ((<$>),(<*>))
4import Control.Monad.Error (runErrorT, throwError)
5import Control.Monad.State (runState)
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Set as Set
9import qualified Data.Traversable as T
11import AST.Expression.General (Expr'(..), dummyLet)
12import qualified AST.Expression.Valid as Valid
13import qualified AST.Expression.Canonical as Canonical
15import AST.Module (CanonicalBody(..))
16import qualified AST.Module as Module
17import qualified AST.Type as Type
18import qualified AST.Variable as Var
19import qualified AST.Annotation as A
20import qualified AST.Declaration as D
21import AST.PrettyPrint (pretty, commaSep)
22import qualified AST.Pattern as P
23import Text.PrettyPrint as P
25import qualified Transform.Canonicalize.Environment as Env
26import qualified Transform.Canonicalize.Setup as Setup
27import qualified Transform.Canonicalize.Type as Canonicalize
28import qualified Transform.Canonicalize.Variable as Canonicalize
29import qualified Transform.SortDefinitions as Transform
30import qualified Transform.Declaration as Transform
33module'
34 :: Module.Interfaces
35 -> Module.ValidModule
36 -> Either [Doc] Module.CanonicalModule
37module' interfaces modul =
38 filterImports <$> modul'
39 where
40 (modul', usedModules) =
41 runState (runErrorT (moduleHelp interfaces modul)) Set.empty
43 filterImports m =
44 let used (name,_) = Set.member name usedModules
45 in
46 m { Module.imports = filter used (Module.imports m) }
49moduleHelp
50 :: Module.Interfaces
51 -> Module.ValidModule
52 -> Env.Canonicalizer [Doc] Module.CanonicalModule
53moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
54 do env <- Setup.environment interfaces modul
55 canonicalDecls <- mapM (declaration env) decls
56 exports' <- resolveExports locals exports
57 return $ modul
58 { Module.exports = exports'
59 , Module.body = body canonicalDecls
60 }
61 where
62 locals :: [Var.Value]
63 locals = concatMap declToValue decls
65 body :: [D.CanonicalDecl] -> Module.CanonicalBody
66 body decls =
67 Module.CanonicalBody
68 { program =
69 let expr = Transform.toExpr (Module.names modul) decls
70 in Transform.sortDefs (dummyLet expr)
71 , types = Map.empty
72 , datatypes =
73 Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]
74 , fixities =
75 [ (assoc,level,op) | D.Fixity assoc level op <- decls ]
76 , aliases =
77 Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]
78 , ports =
79 [ D.wireName wire | D.Wire wire <- decls ]
80 }
83resolveExports
84 :: [Var.Value]
85 -> Var.Listing Var.Value
86 -> Env.Canonicalizer [Doc] [Var.Value]
87resolveExports fullList (Var.Listing partialList open) =
88 if open
89 then return fullList
90 else do
91 valueExports <- getValueExports
92 aliasExports <- concat `fmap` mapM getAliasExport aliases
93 adtExports <- mapM getAdtExport adts
94 return $ valueExports ++ aliasExports ++ adtExports
95 where
96 (allValues, allAliases, allAdts) = splitValues fullList
98 (values, aliases, adts) = splitValues partialList
100 getValueExports =
101 case Set.toList (Set.difference values' allValues') of
102 [] -> return (map Var.Value values)
103 xs -> notFound xs
104 where
105 allValues' = Set.fromList allValues
106 values' = Set.fromList values
108 getAliasExport alias
109 | alias `elem` allAliases =
110 let recordConstructor =
111 if alias `elem` allValues then [Var.Value alias] else []
112 in
113 return $ Var.Alias alias : recordConstructor
115 | otherwise =
116 case List.find (\(name, _ctors) -> name == alias) allAdts of
117 Nothing -> notFound [alias]
118 Just (name, _ctor) ->
119 return [Var.Union name (Var.Listing [] False)]
121 getAdtExport (name, Var.Listing ctors open) =
122 case lookup name allAdts of
123 Nothing -> notFound [name]
124 Just (Var.Listing allCtors _)
125 | open -> return $ Var.Union name (Var.Listing allCtors False)
126 | otherwise ->
127 case filter (`notElem` allCtors) ctors of
128 [] -> return $ Var.Union name (Var.Listing ctors False)
129 unfoundCtors -> notFound unfoundCtors
131 notFound xs =
132 throwError [ P.text "Export Error: trying to export non-existent values:" <+>
133 commaSep (map pretty xs)
134 ]
137{-| Split a list of values into categories so we can work with them
138independently.
139-}
140splitValues :: [Var.Value] -> ([String], [String], [(String, Var.Listing String)])
141splitValues mixedValues =
142 case mixedValues of
143 [] -> ([], [], [])
144 x:xs ->
145 let (values, aliases, adts) = splitValues xs in
146 case x of
147 Var.Value name ->
148 (name : values, aliases, adts)
150 Var.Alias name ->
151 (values, name : aliases, adts)
153 Var.Union name listing ->
154 (values, aliases, (name, listing) : adts)
158declToValue :: D.ValidDecl -> [Var.Value]
159declToValue decl =
160 case decl of
161 D.Definition (Valid.Definition pattern _ _) ->
162 map Var.Value (P.boundVarList pattern)
164 D.Datatype name _tvs ctors ->
165 [ Var.Union name (Var.Listing (map fst ctors) False) ]
167 D.TypeAlias name _ tipe ->
168 case tipe of
169 Type.Record _ _ ->
170 [ Var.Alias name, Var.Value name ]
171 _ -> [ Var.Alias name ]
173 _ -> []
176declaration
177 :: Env.Environment
178 -> D.ValidDecl
179 -> Env.Canonicalizer [Doc] D.CanonicalDecl
180declaration env decl =
181 let canonicalize kind context pattern env v =
182 let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon
183 throw err = P.vcat [ ctx, P.text err ]
184 in
185 Env.onError throw (kind env v)
186 in
187 case decl of
188 D.Definition (Valid.Definition p e t) ->
189 do p' <- canonicalize pattern "definition" p env p
190 e' <- expression env e
191 t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
192 return $ D.Definition (Canonical.Definition p' e' t')
194 D.Datatype name tvars ctors ->
195 D.Datatype name tvars <$> mapM canonicalize' ctors
196 where
197 canonicalize' (ctor,args) =
198 (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args
200 D.TypeAlias name tvars expanded ->
201 do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded
202 return (D.TypeAlias name tvars expanded')
204 D.Wire wire ->
205 do Env.uses ["Native","Ports"]
206 Env.uses ["Native","Json"]
207 D.Wire <$>
208 case wire of
209 D.Input name t ->
210 do t' <- canonicalize Canonicalize.tipe "input" name env t
211 return (D.Input name t')
213 D.Output name e t ->
214 do e' <- expression env e
215 t' <- canonicalize Canonicalize.tipe "output" name env t
216 return (D.Output name e' t')
218 D.Loopback name maybeExpr t ->
219 do maybeExpr' <- T.traverse (expression env) maybeExpr
220 t' <- canonicalize Canonicalize.tipe "input" name env t
221 return (D.Loopback name maybeExpr' t')
223 D.Fixity assoc prec op ->
224 return $ D.Fixity assoc prec op
227expression
228 :: Env.Environment
229 -> Valid.Expr
230 -> Env.Canonicalizer [Doc] Canonical.Expr
231expression env (A.A ann expr) =
232 let go = expression env
233 tipe' environ = format . Canonicalize.tipe environ
234 throw err =
235 P.vcat
236 [ P.text "Error" <+> pretty ann <> P.colon
237 , P.text err
238 ]
239 format = Env.onError throw
240 in
241 A.A ann <$>
242 case expr of
243 Literal lit ->
244 return (Literal lit)
246 Range e1 e2 ->
247 Range <$> go e1 <*> go e2
249 Access e x ->
250 Access <$> go e <*> return x
252 Remove e x ->
253 flip Remove x <$> go e
255 Insert e x v ->
256 flip Insert x <$> go e <*> go v
258 Modify e fs ->
259 Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs
261 Record fs ->
262 Record <$> mapM (\(k,v) -> (,) k <$> go v) fs
264 Binop (Var.Raw op) e1 e2 ->
265 do op' <- format (Canonicalize.variable env op)
266 Binop op' <$> go e1 <*> go e2
268 Lambda p e ->
269 let env' = Env.addPattern p env
270 in
271 Lambda <$> format (pattern env' p) <*> expression env' e
273 App e1 e2 ->
274 App <$> go e1 <*> go e2
276 MultiIf ps ->
277 MultiIf <$> mapM go' ps
278 where
279 go' (b,e) = (,) <$> go b <*> go e
281 Let defs e ->
282 Let <$> mapM rename' defs <*> expression env' e
283 where
284 env' = foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs
285 rename' (Valid.Definition p body mtipe) =
286 Canonical.Definition
287 <$> format (pattern env' p)
288 <*> expression env' body
289 <*> T.traverse (tipe' env') mtipe
291 Var (Var.Raw x) ->
292 Var <$> format (Canonicalize.variable env x)
294 Data name es ->
295 Data name <$> mapM go es
297 ExplicitList es ->
298 ExplicitList <$> mapM go es
300 Case e cases ->
301 Case <$> go e <*> mapM branch cases
302 where
303 branch (p,b) =
304 (,) <$> format (pattern env p)
305 <*> expression (Env.addPattern p env) b
307 Input name tipe ->
308 Input name <$> tipe' env tipe
310 Output name st signal ->
311 Output name <$> tipe' env st <*> go signal
313 Loopback name st maybeExpr ->
314 Loopback name <$> tipe' env st <*> T.traverse go maybeExpr
316 GLShader uid src tipe ->
317 return (GLShader uid src tipe)
320pattern
321 :: Env.Environment
322 -> P.RawPattern
323 -> Env.Canonicalizer String P.CanonicalPattern
324pattern env ptrn =
325 case ptrn of
326 P.Var x -> return $ P.Var x
327 P.Literal lit -> return $ P.Literal lit
328 P.Record fs -> return $ P.Record fs
329 P.Anything -> return P.Anything
330 P.Alias x p -> P.Alias x <$> pattern env p
331 P.Data (Var.Raw name) ps ->
332 P.Data <$> Canonicalize.pvar env name
333 <*> mapM (pattern env) ps