@@ -1,6 +1,6 @@
1module Transform.Canonicalize (interface, metadataModule) where
1module Transform.Canonicalize (interface, metadataModule) where
3−import Control.Arrow (first, second, (***))
3+import Control.Arrow ((***))
4import Control.Monad.Identity
4import Control.Monad.Identity
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6import qualified Data.Set as Set
6import qualified Data.Set as Set
@@ -13,7 +13,8 @@ import SourceSyntax.Pattern
13import SourceSyntax.Helpers (isOp)
13import SourceSyntax.Helpers (isOp)
14import qualified SourceSyntax.Type as Type
14import qualified SourceSyntax.Type as Type
15import qualified Transform.SortDefinitions as SD
15import qualified Transform.SortDefinitions as SD
16−import Text.PrettyPrint
16+import Text.PrettyPrint as P
18interface :: String -> ModuleInterface -> ModuleInterface
19interface :: String -> ModuleInterface -> ModuleInterface
19interface moduleName iface =
20interface moduleName iface =
@@ -50,8 +51,15 @@ renameType rename tipe =
50metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)
51metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)
51metadataModule ifaces modul =
52metadataModule ifaces modul =
52 do program' <- rename initialEnv (program modul)
53 do program' <- rename initialEnv (program modul)
54+ aliases' <- mapM (third renameType') (aliases modul)
55+ datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)
53− return $ modul { program = program' }
56+ return $ modul { program = program', aliases = aliases', datatypes = datatypes' }
58+ second f (a,b) = (,) a `fmap` f b
59+ third f (a,b,c) = (,,) a b `fmap` f c
61+ Either.either (\err -> Left [P.text err]) return . renameType (replace initialEnv)
55 get1 (a,_,_) = a
63 get1 (a,_,_) = a
56 canon (name, importMethod) =
64 canon (name, importMethod) =
57 let pair pre var = (pre ++ drop (length name + 1) var, var)
65 let pair pre var = (pre ++ drop (length name + 1) var, var)
@@ -67,8 +75,7 @@ metadataModule ifaces modul =
67 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
75 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
69 pair n = (n,n)
77 pair n = (n,n)
70− localEnv = concat [ map (pair . get1) (aliases modul)
78+ localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))
71− , map (pair . get1) (datatypes modul) ]
72 globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool"] ++
79 globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool"] ++
73 map (\n -> "_Tuple" ++ show n) [0..9]
80 map (\n -> "_Tuple" ++ show n) [0..9]
74 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
81 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
@@ -96,7 +103,7 @@ replace env v =
96rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)
103rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)
97rename env lexpr@(L t s expr) =
104rename env lexpr@(L t s expr) =
98 let rnm = rename env
105 let rnm = rename env
99− throw err = Left [ text $ "Error " ++ show s ++ "\n" ++ err ]
106+ throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
100 format = Either.either throw return
107 format = Either.either throw return
102 L t s `liftM`
109 L t s `liftM`