@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -Wall #-}
12module Transform.Canonicalize (interface, metadataModule) where
23
34import Control.Arrow ((***))
@@ -11,9 +12,7 @@ import SourceSyntax.Module
1112import SourceSyntax.Expression
1213import SourceSyntax.Location as Loc
1314import qualified SourceSyntax.Pattern as P
14−import SourceSyntax.Helpers (isOp)
1515import qualified SourceSyntax.Type as Type
16−import qualified Transform.SortDefinitions as SD
1716import Text.PrettyPrint as P
1817
1918interface :: String -> ModuleInterface -> ModuleInterface
@@ -41,26 +40,26 @@ interface moduleName iface =
4140 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
4241
4342renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type
44−renameType rename tipe =
45− let rnm = renameType rename in
43+renameType renamer tipe =
44+ let rnm = renameType renamer in
4645 case tipe of
4746 Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
48− Type.Var x -> return tipe
49− Type.Data name ts -> Type.Data <$> rename name <*> mapM rnm ts
47+ Type.Var _ -> return tipe
48+ Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
5049 Type.EmptyRecord -> return tipe
5150 Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext
5251 where rnm' (f,t) = (,) f <$> rnm t
5352
5453metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
5554metadataModule ifaces modul =
56− do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
57− [] -> Right ()
58− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
55+ do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
56+ [] -> Right ()
57+ missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
5958 program' <- rename initialEnv (program modul)
6059 aliases' <- mapM (three4 renameType') (aliases modul)
6160 datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)
62− sendPorts' <- mapM (three3 renameType') (sendPorts modul)
63− recvPorts' <- mapM (three3 renameType') (recvPorts modul)
61+ sendPorts' <- mapM renamePort (sendPorts modul)
62+ recvPorts' <- mapM renamePort (recvPorts modul)
6463 return $ modul { program = program'
6564 , aliases = aliases'
6665 , datatypes = datatypes'
@@ -68,12 +67,8 @@ metadataModule ifaces modul =
6867 , recvPorts = recvPorts' }
6968 where
7069 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
7271 three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d
73− twoAndFour f g (a,b,c,d) =
74− do b' <- f b
75− d' <- g d
76− return (a,b',c,d')
7772 renameType' =
7873 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
7974
@@ -91,10 +86,11 @@ metadataModule ifaces modul =
9186 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
9287 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
9388
94− pair n = (n,n)
95− localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))
96− globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++
97− map (\n -> "_Tuple" ++ show n) [0..9]
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]
9894 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
9995 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
10096
@@ -117,14 +113,14 @@ replace variable env v =
117113 "\nClose matches include: " ++ List.intercalate ", " matches
118114
119115rename :: Env -> LExpr -> Either [Doc] LExpr
120−rename env lexpr@(L s expr) =
116+rename env (L s expr) =
121117 let rnm = rename env
122118 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
123119 format = Either.either throw return
124120 in
125121 L s <$>
126122 case expr of
127− Literal lit -> return expr
123+ Literal _ -> return expr
128124
129125 Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
130126
@@ -135,11 +131,9 @@ rename env lexpr@(L s expr) =
135131 Insert e x v -> flip Insert x <$> rnm e <*> rnm v
136132
137133 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
139135
140− Record fs -> Record <$> mapM frnm fs
141− where
142− frnm (f,e) = (,) f <$> rename env e
136+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs
143137
144138 Binop op e1 e2 ->
145139 do op' <- format (replace "variable" env op)
@@ -157,9 +151,9 @@ rename env lexpr@(L s expr) =
157151 Let defs e -> Let <$> mapM rename' defs <*> rename env' e
158152 where
159153 env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
160− rename' (Definition p exp mtipe) =
154+ rename' (Definition p body mtipe) =
161155 Definition <$> format (renamePattern env' p)
162− <*> rename env' exp
156+ <*> rename env' body
163157 <*> case mtipe of
164158 Nothing -> return Nothing
165159 Just tipe -> Just <$> renameType (format . replace "variable" env') tipe
@@ -172,8 +166,8 @@ rename env lexpr@(L s expr) =
172166
173167 Case e cases -> Case <$> rnm e <*> mapM branch cases
174168 where
175− branch (pattern,e) = (,) <$> format (renamePattern env pattern)
176− <*> rename (extend env pattern) e
169+ branch (pattern,b) = (,) <$> format (renamePattern env pattern)
170+ <*> rename (extend env pattern) b
177171
178172 Markdown uid md es -> Markdown uid md <$> mapM rnm es
179173