@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -Wall #-}
1module Transform.Canonicalize (interface, metadataModule) where
2module Transform.Canonicalize (interface, metadataModule) where
3import Control.Arrow ((***))
4import Control.Arrow ((***))
@@ -11,9 +12,7 @@ import SourceSyntax.Module
11import SourceSyntax.Expression
12import SourceSyntax.Expression
12import SourceSyntax.Location as Loc
13import SourceSyntax.Location as Loc
13import qualified SourceSyntax.Pattern as P
14import qualified SourceSyntax.Pattern as P
14−import SourceSyntax.Helpers (isOp)
15import qualified SourceSyntax.Type as Type
15import qualified SourceSyntax.Type as Type
16−import qualified Transform.SortDefinitions as SD
17import Text.PrettyPrint as P
16import Text.PrettyPrint as P
19interface :: String -> ModuleInterface -> ModuleInterface
18interface :: String -> ModuleInterface -> ModuleInterface
@@ -41,26 +40,26 @@ interface moduleName iface =
41 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
40 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
43renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type
42renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type
44−renameType rename tipe =
43+renameType renamer tipe =
45− let rnm = renameType rename in
44+ let rnm = renameType renamer in
46 case tipe of
45 case tipe of
47 Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
46 Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
48− Type.Var x -> return tipe
47+ Type.Var _ -> return tipe
49− Type.Data name ts -> Type.Data <$> rename name <*> mapM rnm ts
48+ Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
50 Type.EmptyRecord -> return tipe
49 Type.EmptyRecord -> return tipe
51 Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext
50 Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext
52 where rnm' (f,t) = (,) f <$> rnm t
51 where rnm' (f,t) = (,) f <$> rnm t
54metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
53metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
55metadataModule ifaces modul =
54metadataModule ifaces modul =
56− do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
55+ do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
57− [] -> Right ()
56+ [] -> Right ()
58− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
57+ missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
59 program' <- rename initialEnv (program modul)
58 program' <- rename initialEnv (program modul)
60 aliases' <- mapM (three4 renameType') (aliases modul)
59 aliases' <- mapM (three4 renameType') (aliases modul)
61 datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)
60 datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)
62− sendPorts' <- mapM (three3 renameType') (sendPorts modul)
61+ sendPorts' <- mapM renamePort (sendPorts modul)
63− recvPorts' <- mapM (three3 renameType') (recvPorts modul)
62+ recvPorts' <- mapM renamePort (recvPorts modul)
64 return $ modul { program = program'
63 return $ modul { program = program'
65 , aliases = aliases'
64 , aliases = aliases'
66 , datatypes = datatypes'
65 , datatypes = datatypes'
@@ -68,12 +67,8 @@ metadataModule ifaces modul =
68 , recvPorts = recvPorts' }
67 , recvPorts = recvPorts' }
70 two2 f (a,b) = (,) a <$> f b
69 two2 f (a,b) = (,) a <$> f b
71− three3 f (a,b,c) = (,,) a b <$> f c
70+ renamePort (name,expr,tipe) = (,,) name <$> rename initialEnv expr <*> renameType' tipe
72 three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d
71 three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d
73− twoAndFour f g (a,b,c,d) =
77 renameType' =
72 renameType' =
78 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
73 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
@@ -91,10 +86,11 @@ metadataModule ifaces modul =
91 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
86 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
92 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
87 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
94− pair n = (n,n)
89+ two n = (n,n)
95− localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))
90+ localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))
96− globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++
92+ map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++
97− map (\n -> "_Tuple" ++ show n) [0..9]
93+ map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]
98 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
94 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
99 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
95 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
@@ -117,14 +113,14 @@ replace variable env v =
117 "\nClose matches include: " ++ List.intercalate ", " matches
113 "\nClose matches include: " ++ List.intercalate ", " matches
119rename :: Env -> LExpr -> Either [Doc] LExpr
115rename :: Env -> LExpr -> Either [Doc] LExpr
120−rename env lexpr@(L s expr) =
116+rename env (L s expr) =
121 let rnm = rename env
117 let rnm = rename env
122 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
118 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
123 format = Either.either throw return
119 format = Either.either throw return
126 case expr of
122 case expr of
127− Literal lit -> return expr
123+ Literal _ -> return expr
129 Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
125 Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
@@ -135,11 +131,9 @@ rename env lexpr@(L s expr) =
135 Insert e x v -> flip Insert x <$> rnm e <*> rnm v
131 Insert e x v -> flip Insert x <$> rnm e <*> rnm v
137 Modify e fs ->
133 Modify e fs ->
138− Modify <$> rnm e <*> mapM (\(x,e) -> (,) x <$> rnm e) fs
134+ Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs
140− Record fs -> Record <$> mapM frnm fs
136+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs
142− frnm (f,e) = (,) f <$> rename env e
144 Binop op e1 e2 ->
138 Binop op e1 e2 ->
145 do op' <- format (replace "variable" env op)
139 do op' <- format (replace "variable" env op)
@@ -157,9 +151,9 @@ rename env lexpr@(L s expr) =
157 Let defs e -> Let <$> mapM rename' defs <*> rename env' e
151 Let defs e -> Let <$> mapM rename' defs <*> rename env' e
159 env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
153 env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
160− rename' (Definition p exp mtipe) =
154+ rename' (Definition p body mtipe) =
161 Definition <$> format (renamePattern env' p)
155 Definition <$> format (renamePattern env' p)
162− <*> rename env' exp
156+ <*> rename env' body
163 <*> case mtipe of
157 <*> case mtipe of
164 Nothing -> return Nothing
158 Nothing -> return Nothing
165 Just tipe -> Just <$> renameType (format . replace "variable" env') tipe
159 Just tipe -> Just <$> renameType (format . replace "variable" env') tipe
@@ -172,8 +166,8 @@ rename env lexpr@(L s expr) =
173 Case e cases -> Case <$> rnm e <*> mapM branch cases
167 Case e cases -> Case <$> rnm e <*> mapM branch cases
175− branch (pattern,e) = (,) <$> format (renamePattern env pattern)
169+ branch (pattern,b) = (,) <$> format (renamePattern env pattern)
176− <*> rename (extend env pattern) e
170+ <*> rename (extend env pattern) b
178 Markdown uid md es -> Markdown uid md <$> mapM rnm es
172 Markdown uid md es -> Markdown uid md <$> mapM rnm es