git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Transform/Canonicalize.hs
183 lines 7.3 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Transform.Canonicalize (interface, metadataModule) where
4import Control.Arrow ((***))
5import Control.Applicative (Applicative,(<$>),(<*>))
6import Control.Monad.Identity
7import qualified Data.Map as Map
8import qualified Data.Set as Set
9import qualified Data.List as List
10import qualified Data.Either as Either
11import SourceSyntax.Module
12import SourceSyntax.Expression
13import SourceSyntax.Location as Loc
14import qualified SourceSyntax.Pattern as P
15import qualified SourceSyntax.Type as Type
16import Text.PrettyPrint as P
18interface :: String -> ModuleInterface -> ModuleInterface
19interface moduleName iface =
20 ModuleInterface
21 { iVersion = iVersion iface
22 , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))
23 , iImports = iImports iface
24 , iAdts = map (both prefix renameCtors) (iAdts iface)
25 , iAliases = map (both prefix renameType') (iAliases iface)
26 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing
27 }
28 where
29 both f g (a,b,c,d) = (f a, b, g c, d)
30 prefix name = moduleName ++ "." ++ name
32 pair name = (name, moduleName ++ "." ++ name)
33 canon (name,_,_,_) = pair name
34 canons = Map.fromList $ concat
35 [ map canon (iAdts iface), map canon (iAliases iface) ]
37 renameCtors ctors =
38 map (prefix *** map renameType') ctors
39 renameType' =
40 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
42renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type
43renameType renamer tipe =
44 let rnm = renameType renamer in
45 case tipe of
46 Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
47 Type.Var _ -> return tipe
48 Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
49 Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext
50 where rnm' (f,t) = (,) f <$> rnm t
52metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
53metadataModule ifaces modul =
54 do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
55 [] -> Right ()
56 missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
57 program' <- rename initialEnv (program modul)
58 aliases' <- mapM (three4 renameType') (aliases modul)
59 datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)
60 return $ modul { program = program'
61 , aliases = aliases'
62 , datatypes = datatypes' }
63 where
64 two2 f (a,b) = (,) a <$> f b
65 three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d
66 renameType' =
67 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
69 get1 (a,_,_,_) = a
70 canon (name, importMethod) =
71 let pair pre var = (pre ++ drop (length name + 1) var, var)
72 iface = ifaces Map.! name
73 allNames = concat [ Map.keys (iTypes iface)
74 , map get1 (iAliases iface)
75 , concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]
76 in case importMethod of
77 As alias -> map (pair (alias ++ ".")) allNames
78 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames
79 where vs = Set.fromList vars
80 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
81 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
83 two n = (n,n)
84 localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))
85 globalEnv =
86 map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++
87 map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]
88 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
89 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
91type Env = Map.Map String String
93extend :: Env -> P.Pattern -> Env
94extend env pattern = Map.union (Map.fromList (zip xs xs)) env
95 where xs = Set.toList (P.boundVars pattern)
98replace :: String -> Env -> String -> Either String String
99replace variable env v =
100 if List.isPrefixOf "Native." v then return v else
101 case Map.lookup v env of
102 Just v' -> return v'
103 Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg
104 where
105 matches = filter (List.isInfixOf v) (Map.keys env)
106 msg = if null matches then "" else
107 "\nClose matches include: " ++ List.intercalate ", " matches
109rename :: Env -> LExpr -> Either [Doc] LExpr
110rename env (L s expr) =
111 let rnm = rename env
112 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
113 format = Either.either throw return
114 renameType' env = renameType (format . replace "variable" env)
115 in
116 L s <$>
117 case expr of
118 Literal _ -> return expr
120 Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
122 Access e x -> Access <$> rnm e <*> return x
124 Remove e x -> flip Remove x <$> rnm e
126 Insert e x v -> flip Insert x <$> rnm e <*> rnm v
128 Modify e fs ->
129 Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs
131 Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs
133 Binop op e1 e2 ->
134 do op' <- format (replace "variable" env op)
135 Binop op' <$> rnm e1 <*> rnm e2
137 Lambda pattern e ->
138 let env' = extend env pattern in
139 Lambda <$> format (renamePattern env' pattern) <*> rename env' e
141 App e1 e2 -> App <$> rnm e1 <*> rnm e2
143 MultiIf ps -> MultiIf <$> mapM grnm ps
144 where grnm (b,e) = (,) <$> rnm b <*> rnm e
146 Let defs e -> Let <$> mapM rename' defs <*> rename env' e
147 where
148 env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
149 rename' (Definition p body mtipe) =
150 Definition <$> format (renamePattern env' p)
151 <*> rename env' body
152 <*> case mtipe of
153 Nothing -> return Nothing
154 Just tipe -> Just <$> renameType' env' tipe
156 Var x -> Var <$> format (replace "variable" env x)
158 Data name es -> Data name <$> mapM rnm es
160 ExplicitList es -> ExplicitList <$> mapM rnm es
162 Case e cases -> Case <$> rnm e <*> mapM branch cases
163 where
164 branch (pattern,b) = (,) <$> format (renamePattern env pattern)
165 <*> rename (extend env pattern) b
167 Markdown uid md es -> Markdown uid md <$> mapM rnm es
169 PortIn name st -> PortIn name <$> renameType' env st
171 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
174renamePattern :: Env -> P.Pattern -> Either String P.Pattern
175renamePattern env pattern =
176 case pattern of
177 P.PVar _ -> return pattern
178 P.PLiteral _ -> return pattern
179 P.PRecord _ -> return pattern
180 P.PAnything -> return pattern
181 P.PAlias x p -> P.PAlias x <$> renamePattern env p
182 P.PData name ps -> P.PData <$> replace "pattern" env name
183 <*> mapM (renamePattern env) ps