git.iko.soy/elk
on 577fc17 help sign in
elk/compiler/Transform/Canonicalize.hs
258 lines 9.4 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Transform.Canonicalize (module', filterExports) where
4import Control.Applicative ((<$>),(<*>))
5import Control.Monad.Error (runErrorT, throwError)
6import Control.Monad.State (runState)
7import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Set as Set
10import qualified Data.Traversable as T
12import AST.Expression.General (Expr'(..), dummyLet)
13import qualified AST.Expression.Valid as Valid
14import qualified AST.Expression.Canonical as Canonical
16import AST.Module (CanonicalBody(..))
17import qualified AST.Module as Module
18import qualified AST.Type as Type
19import qualified AST.Variable as Var
20import qualified AST.Annotation as A
21import qualified AST.Declaration as D
22import AST.PrettyPrint (pretty, commaSep)
23import qualified AST.Pattern as P
24import Text.PrettyPrint as P
26import Transform.Canonicalize.Environment as Env
27import qualified Transform.Canonicalize.Setup as Setup
28import qualified Transform.Canonicalize.Type as Canonicalize
29import qualified Transform.Canonicalize.Variable as Canonicalize
30import qualified Transform.SortDefinitions as Transform
31import 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) }
44moduleHelp :: Module.Interfaces -> Module.ValidModule
45 -> Canonicalizer [Doc] Module.CanonicalModule
46moduleHelp interfaces modul@(Module.Module _ _ exs _ decls) =
47 do env <- Setup.environment interfaces modul
48 canonicalDecls <- mapM (declaration env) decls
49 exports' <- delist locals exs
50 return $ modul { Module.exports = exports'
51 , Module.body = body canonicalDecls
52 }
53 where
54 locals :: [Var.Value]
55 locals = concatMap declToValue decls
57 body :: [D.CanonicalDecl] -> Module.CanonicalBody
58 body decls =
59 Module.CanonicalBody
60 { program =
61 let expr = Transform.toExpr (Module.getName modul) decls
62 in Transform.sortDefs (dummyLet expr)
63 , types = Map.empty
64 , datatypes =
65 Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]
66 , fixities =
67 [ (assoc,level,op) | D.Fixity assoc level op <- decls ]
68 , aliases =
69 Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]
70 , ports =
71 [ D.portName port | D.Port port <- decls ]
72 }
74delist :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]
75delist fullList (Var.Listing partial open)
76 | open = return fullList
77 | otherwise = go [] (List.sort fullList) (List.sort partial)
78 where
79 notFound xs =
80 throwError [ P.text "Export Error: trying to export non-existent values:" <+>
81 commaSep (map pretty xs)
82 ]
84 go list full partial =
85 case (full, partial) of
86 (_, []) -> return list
87 ([], _) -> notFound partial
88 (x:xs, y:ys) ->
89 case (x,y) of
90 (Var.Value x', Var.Value y') | x' == y' ->
91 go (x : list) xs ys
93 (Var.Alias x', Var.Alias y') | x' == y' ->
94 go (x : list) xs ys
96 (Var.ADT x' _, Var.Alias y') | x' == y' ->
97 go (Var.ADT x' (Var.Listing [] False) : list) xs ys
99 (Var.ADT x' (Var.Listing xctors _ ),
100 Var.ADT y' (Var.Listing yctors open)) | x' == y' ->
101 if open
102 then go (x : list) xs ys
103 else case filter (`notElem` xctors) yctors of
104 [] -> go (y : list) xs ys
105 bads -> notFound bads
107 _ -> go list xs partial
109filterExports :: Module.Types -> [Var.Value] -> Module.Types
110filterExports types values =
111 Map.fromList (concatMap getValue values)
112 where
113 getValue :: Var.Value -> [(String, Type.CanonicalType)]
114 getValue value =
115 case value of
116 Var.Value x -> get x
117 Var.Alias x -> get x
118 Var.ADT _ (Var.Listing ctors _) -> concatMap get ctors
120 get :: String -> [(String, Type.CanonicalType)]
121 get x =
122 case Map.lookup x types of
123 Just t -> [(x,t)]
124 Nothing -> []
126declToValue :: D.ValidDecl -> [Var.Value]
127declToValue decl =
128 case decl of
129 D.Definition (Valid.Definition pattern _ _) ->
130 map Var.Value (P.boundVarList pattern)
132 D.Datatype name _tvs ctors ->
133 [ Var.ADT name (Var.Listing (map fst ctors) False) ]
135 D.TypeAlias name _ (Type.Record _ _) ->
136 [ Var.Alias name ]
138 _ -> []
140declaration :: Environment -> D.ValidDecl -> Canonicalizer [Doc] D.CanonicalDecl
141declaration env decl =
142 let canonicalize kind context pattern env v =
143 let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon
144 throw err = P.vcat [ ctx, P.text err ]
145 in
146 Env.onError throw (kind env v)
147 in
148 case decl of
149 D.Definition (Valid.Definition p e t) ->
150 do p' <- canonicalize pattern "definition" p env p
151 e' <- expression env e
152 t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
153 return $ D.Definition (Canonical.Definition p' e' t')
155 D.Datatype name tvars ctors ->
156 D.Datatype name tvars <$> mapM canonicalize' ctors
157 where
158 canonicalize' (ctor,args) =
159 (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args
161 D.TypeAlias name tvars expanded ->
162 do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded
163 return (D.TypeAlias name tvars expanded')
165 D.Port port -> do
166 Env.uses "Native.Ports"
167 Env.uses "Native.Json"
168 D.Port <$> case port of
169 D.In name t ->
170 do t' <- canonicalize Canonicalize.tipe "port" name env t
171 return (D.In name t')
172 D.Out name e t ->
173 do e' <- expression env e
174 t' <- canonicalize Canonicalize.tipe "port" name env t
175 return (D.Out name e' t')
177 D.Fixity assoc prec op -> return $ D.Fixity assoc prec op
180expression :: Environment -> Valid.Expr -> Canonicalizer [Doc] Canonical.Expr
181expression env (A.A ann expr) =
182 let go = expression env
183 tipe' environ = format . Canonicalize.tipe environ
184 throw err = P.vcat [ P.text "Error" <+> pretty ann <> P.colon
185 , P.text err ]
186 format = Env.onError throw
187 in
188 A.A ann <$>
189 case expr of
190 Literal lit -> return (Literal lit)
192 Range e1 e2 -> Range <$> go e1 <*> go e2
194 Access e x -> Access <$> go e <*> return x
196 Remove e x -> flip Remove x <$> go e
198 Insert e x v -> flip Insert x <$> go e <*> go v
200 Modify e fs ->
201 Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs
203 Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fs
205 Binop (Var.Raw op) e1 e2 ->
206 do op' <- format (Canonicalize.variable env op)
207 Binop op' <$> go e1 <*> go e2
209 Lambda p e ->
210 let env' = update p env in
211 Lambda <$> format (pattern env' p) <*> expression env' e
213 App e1 e2 -> App <$> go e1 <*> go e2
215 MultiIf ps -> MultiIf <$> mapM go' ps
216 where go' (b,e) = (,) <$> go b <*> go e
218 Let defs e -> Let <$> mapM rename' defs <*> expression env' e
219 where
220 env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs
221 rename' (Valid.Definition p body mtipe) =
222 Canonical.Definition
223 <$> format (pattern env' p)
224 <*> expression env' body
225 <*> T.traverse (tipe' env') mtipe
227 Var (Var.Raw x) -> Var <$> format (Canonicalize.variable env x)
229 Data name es -> Data name <$> mapM go es
231 ExplicitList es -> ExplicitList <$> mapM go es
233 Case e cases -> Case <$> go e <*> mapM branch cases
234 where
235 branch (p,b) = (,) <$> format (pattern env p)
236 <*> expression (update p env) b
238 Markdown uid md es ->
239 do Env.uses "Text"
240 Markdown uid md <$> mapM go es
242 PortIn name st -> PortIn name <$> tipe' env st
244 PortOut name st signal -> PortOut name <$> tipe' env st <*> go signal
246 GLShader uid src tipe -> return (GLShader uid src tipe)
248pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern
249pattern env ptrn =
250 case ptrn of
251 P.Var x -> return $ P.Var x
252 P.Literal lit -> return $ P.Literal lit
253 P.Record fs -> return $ P.Record fs
254 P.Anything -> return P.Anything
255 P.Alias x p -> P.Alias x <$> pattern env p
256 P.Data (Var.Raw name) ps ->
257 P.Data <$> Canonicalize.pvar env name
258 <*> mapM (pattern env) ps