git.iko.soy/elk
on d87affe help sign in
elk/src/Transform/Canonicalize.hs
309 lines 10 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 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' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule
34module' interfaces modul =
35 filterImports <$> modul'
36 where
37 (modul', usedModules) =
38 runState (runErrorT (moduleHelp interfaces modul)) Set.empty
40 filterImports m =
41 let used (name,_) = Set.member name usedModules
42 in m { Module.imports = filter used (Module.imports m) }
45moduleHelp :: Module.Interfaces -> Module.ValidModule
46 -> Canonicalizer [Doc] Module.CanonicalModule
47moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
48 do env <- Setup.environment interfaces modul
49 canonicalDecls <- mapM (declaration env) decls
50 exports' <- resolveExports locals exports
51 return $ modul
52 { Module.exports = exports'
53 , Module.body = body canonicalDecls
54 }
55 where
56 locals :: [Var.Value]
57 locals = concatMap declToValue decls
59 body :: [D.CanonicalDecl] -> Module.CanonicalBody
60 body decls =
61 Module.CanonicalBody
62 { program =
63 let expr = Transform.toExpr (Module.names modul) decls
64 in Transform.sortDefs (dummyLet expr)
65 , types = Map.empty
66 , datatypes =
67 Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]
68 , fixities =
69 [ (assoc,level,op) | D.Fixity assoc level op <- decls ]
70 , aliases =
71 Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]
72 , ports =
73 [ D.portName port | D.Port port <- decls ]
74 }
77resolveExports :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]
78resolveExports fullList (Var.Listing partialList open) =
79 if open
80 then return fullList
81 else do
82 valueExports <- getValueExports
83 aliasExports <- concat `fmap` mapM getAliasExport aliases
84 adtExports <- mapM getAdtExport adts
85 return $ valueExports ++ aliasExports ++ adtExports
86 where
87 (allValues, allAliases, allAdts) = splitValues fullList
89 (values, aliases, adts) = splitValues partialList
91 getValueExports =
92 case Set.toList (Set.difference values' allValues') of
93 [] -> return (map Var.Value values)
94 xs -> notFound xs
95 where
96 allValues' = Set.fromList allValues
97 values' = Set.fromList values
99 getAliasExport alias
100 | alias `elem` allAliases =
101 let recordConstructor =
102 if alias `elem` allValues then [Var.Value alias] else []
103 in
104 return $ Var.Alias alias : recordConstructor
106 | otherwise =
107 case List.find (\(name, _ctors) -> name == alias) allAdts of
108 Nothing -> notFound [alias]
109 Just (name, _ctor) ->
110 return [Var.ADT name (Var.Listing [] False)]
112 getAdtExport (name, Var.Listing ctors open) =
113 case lookup name allAdts of
114 Nothing -> notFound [name]
115 Just (Var.Listing allCtors _)
116 | open -> return $ Var.ADT name (Var.Listing allCtors False)
117 | otherwise ->
118 case filter (`notElem` allCtors) ctors of
119 [] -> return $ Var.ADT name (Var.Listing ctors False)
120 unfoundCtors -> notFound unfoundCtors
122 notFound xs =
123 throwError [ P.text "Export Error: trying to export non-existent values:" <+>
124 commaSep (map pretty xs)
125 ]
128{-| Split a list of values into categories so we can work with them
129independently.
130-}
131splitValues :: [Var.Value] -> ([String], [String], [(String, Var.Listing String)])
132splitValues mixedValues =
133 case mixedValues of
134 [] -> ([], [], [])
135 x:xs ->
136 let (values, aliases, adts) = splitValues xs in
137 case x of
138 Var.Value name ->
139 (name : values, aliases, adts)
141 Var.Alias name ->
142 (values, name : aliases, adts)
144 Var.ADT name listing ->
145 (values, aliases, (name, listing) : adts)
149declToValue :: D.ValidDecl -> [Var.Value]
150declToValue decl =
151 case decl of
152 D.Definition (Valid.Definition pattern _ _) ->
153 map Var.Value (P.boundVarList pattern)
155 D.Datatype name _tvs ctors ->
156 [ Var.ADT name (Var.Listing (map fst ctors) False) ]
158 D.TypeAlias name _ tipe ->
159 case tipe of
160 Type.Record _ _ ->
161 [ Var.Alias name, Var.Value name ]
162 _ -> [ Var.Alias name ]
164 _ -> []
167declaration :: Environment -> D.ValidDecl -> Canonicalizer [Doc] D.CanonicalDecl
168declaration env decl =
169 let canonicalize kind context pattern env v =
170 let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon
171 throw err = P.vcat [ ctx, P.text err ]
172 in
173 Env.onError throw (kind env v)
174 in
175 case decl of
176 D.Definition (Valid.Definition p e t) ->
177 do p' <- canonicalize pattern "definition" p env p
178 e' <- expression env e
179 t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
180 return $ D.Definition (Canonical.Definition p' e' t')
182 D.Datatype name tvars ctors ->
183 D.Datatype name tvars <$> mapM canonicalize' ctors
184 where
185 canonicalize' (ctor,args) =
186 (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args
188 D.TypeAlias name tvars expanded ->
189 do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded
190 return (D.TypeAlias name tvars expanded')
192 D.Port port ->
193 do Env.uses ["Native","Ports"]
194 Env.uses ["Native","Json"]
195 D.Port <$>
196 case port of
197 D.In name t ->
198 do t' <- canonicalize Canonicalize.tipe "port" name env t
199 return (D.In name t')
200 D.Out name e t ->
201 do e' <- expression env e
202 t' <- canonicalize Canonicalize.tipe "port" name env t
203 return (D.Out name e' t')
205 D.Fixity assoc prec op ->
206 return $ D.Fixity assoc prec op
209expression :: Environment -> Valid.Expr -> Canonicalizer [Doc] Canonical.Expr
210expression env (A.A ann expr) =
211 let go = expression env
212 tipe' environ = format . Canonicalize.tipe environ
213 throw err =
214 P.vcat
215 [ P.text "Error" <+> pretty ann <> P.colon
216 , P.text err
217 ]
218 format = Env.onError throw
219 in
220 A.A ann <$>
221 case expr of
222 Literal lit ->
223 return (Literal lit)
225 Range e1 e2 ->
226 Range <$> go e1 <*> go e2
228 Access e x ->
229 Access <$> go e <*> return x
231 Remove e x ->
232 flip Remove x <$> go e
234 Insert e x v ->
235 flip Insert x <$> go e <*> go v
237 Modify e fs ->
238 Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs
240 Record fs ->
241 Record <$> mapM (\(k,v) -> (,) k <$> go v) fs
243 Binop (Var.Raw op) e1 e2 ->
244 do op' <- format (Canonicalize.variable env op)
245 Binop op' <$> go e1 <*> go e2
247 Lambda p e ->
248 let env' = update p env in
249 Lambda <$> format (pattern env' p) <*> expression env' e
251 App e1 e2 ->
252 App <$> go e1 <*> go e2
254 MultiIf ps ->
255 MultiIf <$> mapM go' ps
256 where
257 go' (b,e) = (,) <$> go b <*> go e
259 Let defs e ->
260 Let <$> mapM rename' defs <*> expression env' e
261 where
262 env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs
263 rename' (Valid.Definition p body mtipe) =
264 Canonical.Definition
265 <$> format (pattern env' p)
266 <*> expression env' body
267 <*> T.traverse (tipe' env') mtipe
269 Var (Var.Raw x) ->
270 Var <$> format (Canonicalize.variable env x)
272 Data name es ->
273 Data name <$> mapM go es
275 ExplicitList es ->
276 ExplicitList <$> mapM go es
278 Case e cases ->
279 Case <$> go e <*> mapM branch cases
280 where
281 branch (p,b) =
282 (,) <$> format (pattern env p)
283 <*> expression (update p env) b
285 Markdown uid md ->
286 do Env.uses ["Text"]
287 return (Markdown uid md)
289 PortIn name st ->
290 PortIn name <$> tipe' env st
292 PortOut name st signal ->
293 PortOut name <$> tipe' env st <*> go signal
295 GLShader uid src tipe ->
296 return (GLShader uid src tipe)
299pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern
300pattern env ptrn =
301 case ptrn of
302 P.Var x -> return $ P.Var x
303 P.Literal lit -> return $ P.Literal lit
304 P.Record fs -> return $ P.Record fs
305 P.Anything -> return P.Anything
306 P.Alias x p -> P.Alias x <$> pattern env p
307 P.Data (Var.Raw name) ps ->
308 P.Data <$> Canonicalize.pvar env name
309 <*> mapM (pattern env) ps