git.iko.soy/elk
on 4bec310 help sign in
elk/compiler/Transform/Canonicalize.hs
191 lines 7.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Canonicalize (interface, metadataModule) where
4import Control.Arrow ((***))
5import Control.Applicative (Applicative,(<$>),(<*>))
6import Control.Monad.Identity
7import qualified Data.Either as Either
8import qualified Data.List as List
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import qualified Data.Traversable as T
12import SourceSyntax.Annotation as A
13import SourceSyntax.Expression
14import SourceSyntax.Module
15import SourceSyntax.PrettyPrint (pretty)
16import qualified SourceSyntax.Pattern as P
17import qualified SourceSyntax.Type as Type
18import qualified SourceSyntax.Variable as Var
19import Text.PrettyPrint as P
21interface :: String -> ModuleInterface -> ModuleInterface
22interface moduleName iface =
23 ModuleInterface
24 { iVersion = iVersion iface
25 , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))
26 , iImports = iImports iface
27 , iAdts = map (both prefix renameCtors) (iAdts iface)
28 , iAliases = map (both prefix renameType') (iAliases iface)
29 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing
30 , iPorts = iPorts iface
31 }
32 where
33 both f g (a,b,c) = (f a, b, g c)
34 prefix name = moduleName ++ "." ++ name
36 pair name = (name, moduleName ++ "." ++ name)
37 canon (name,_,_) = pair name
38 canons = Map.fromList $ concat
39 [ map canon (iAdts iface), map canon (iAliases iface) ]
41 renameCtors ctors =
42 map (prefix *** map renameType') ctors
43 renameType' =
44 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
46renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type
47renameType renamer tipe =
48 let rnm = renameType renamer in
49 case tipe of
50 Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
51 Type.Var _ -> return tipe
52 Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
53 Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext
54 where rnm' (f,t) = (,) f <$> rnm t
56metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
57metadataModule ifaces modul =
58 do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
59 [] -> Right ()
60 missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ++
61 "\n You may need to compile with the --make flag to detect modules you have written."
62 ]
63 program' <- rename initialEnv (program modul)
64 aliases' <- mapM (three3 renameType') (aliases modul)
65 datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)
66 return $ modul { program = program'
67 , aliases = aliases'
68 , datatypes = datatypes' }
69 where
70 two2 f (a,b) = (,) a <$> f b
71 three3 f (a,b,c) = (,,) a b <$> f c
72 renameType' =
73 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
75 get1 (a,_,_) = a
76 canon (name, importMethod) =
77 let pair pre var = (pre ++ drop (length name + 1) var, var)
78 iface = ifaces Map.! name
79 allNames = concat [ Map.keys (iTypes iface)
80 , map get1 (iAliases iface)
81 , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]
82 in case importMethod of
83 As alias -> map (pair (alias ++ ".")) allNames
84 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames
85 where vs = Set.fromList vars
86 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
87 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
89 two n = (n,n)
90 localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))
91 globalEnv =
92 map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++
93 map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]
94 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
95 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
97type Env = Map.Map String String
99extend :: Env -> P.Pattern -> Env
100extend env pattern = Map.union (Map.fromList (zip xs xs)) env
101 where xs = P.boundVarList pattern
103replace :: String -> Env -> String -> Either String String
104replace variable env v =
105 if List.isPrefixOf "Native." v then return v else
106 case Map.lookup v env of
107 Just v' -> return v'
108 Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg
109 where
110 matches = filter (List.isInfixOf v) (Map.keys env)
111 msg = if null matches then "" else
112 "\nClose matches include: " ++ List.intercalate ", " matches
114-- TODO: Var.Raw -> Var.Canonical
115rename :: Env -> Expr -> Either [Doc] Expr
116rename env (A ann expr) =
117 let rnm = rename env
118 throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon
119 , P.text err
120 ]
121 ]
122 format = Either.either throw return
123 renameType' environ = renameType (format . replace "variable" environ)
124 in
125 A ann <$>
126 case expr of
127 Literal _ -> return expr
129 Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
131 Access e x -> Access <$> rnm e <*> return x
133 Remove e x -> flip Remove x <$> rnm e
135 Insert e x v -> flip Insert x <$> rnm e <*> rnm v
137 Modify e fs ->
138 Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs
140 Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs
142 Binop op e1 e2 ->
143 do op' <- format (replace "variable" env op)
144 Binop op' <$> rnm e1 <*> rnm e2
146 Lambda pattern e ->
147 let env' = extend env pattern in
148 Lambda <$> format (renamePattern env' pattern) <*> rename env' e
150 App e1 e2 -> App <$> rnm e1 <*> rnm e2
152 MultiIf ps -> MultiIf <$> mapM grnm ps
153 where grnm (b,e) = (,) <$> rnm b <*> rnm e
155 Let defs e -> Let <$> mapM rename' defs <*> rename env' e
156 where
157 env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
158 rename' (Definition p body mtipe) =
159 Definition <$> format (renamePattern env' p)
160 <*> rename env' body
161 <*> T.traverse (renameType' env') mtipe
163 -- TODO: Raw -> Canonical
164 Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)
166 Data name es -> Data name <$> mapM rnm es
168 ExplicitList es -> ExplicitList <$> mapM rnm es
170 Case e cases -> Case <$> rnm e <*> mapM branch cases
171 where
172 branch (pattern,b) = (,) <$> format (renamePattern env pattern)
173 <*> rename (extend env pattern) b
175 Markdown uid md es -> Markdown uid md <$> mapM rnm es
177 PortIn name st -> PortIn name <$> renameType' env st
179 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
182renamePattern :: Env -> P.Pattern -> Either String P.Pattern
183renamePattern env pattern =
184 case pattern of
185 P.Var _ -> return pattern
186 P.Literal _ -> return pattern
187 P.Record _ -> return pattern
188 P.Anything -> return pattern
189 P.Alias x p -> P.Alias x <$> renamePattern env p
190 P.Data name ps -> P.Data <$> replace "pattern" env name
191 <*> mapM (renamePattern env) ps