3d78042 · elk · git.iko.soy

1module Transform.Canonicalize (interface, metadataModule) where

2

3import Control.Arrow ((***))

4+import Control.Applicative (Applicative,(<$>),(<*>))

4import Control.Monad.Identity

5import Control.Monad.Identity

5import qualified Data.Map as Map

6import qualified Data.Map as Map

6import qualified Data.Set as Set

7import qualified Data.Set as Set

9import SourceSyntax.Module

10import SourceSyntax.Module

10import SourceSyntax.Expression

11import SourceSyntax.Expression

11import SourceSyntax.Location as Loc

12import SourceSyntax.Location as Loc

12−import SourceSyntax.Pattern

13+import qualified SourceSyntax.Pattern as P

13import SourceSyntax.Helpers (isOp)

14import SourceSyntax.Helpers (isOp)

14import qualified SourceSyntax.Type as Type

15import qualified SourceSyntax.Type as Type

15import qualified Transform.SortDefinitions as SD

16import qualified Transform.SortDefinitions as SD

39 renameType' =

40 renameType' =

40 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

41 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

41

42

42−renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type

43+renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type

43renameType rename tipe =

44renameType rename tipe =

44 let rnm = renameType rename in

45 let rnm = renameType rename in

45 case tipe of

46 case tipe of

46− Type.Lambda a b -> Type.Lambda `liftM` rnm a `ap` rnm b

47+ Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

47 Type.Var x -> return tipe

48 Type.Var x -> return tipe

48− Type.Data name ts -> Type.Data `liftM` rename name `ap` mapM rnm ts

49+ Type.Data name ts -> Type.Data <$> rename name <*> mapM rnm ts

49 Type.EmptyRecord -> return tipe

50 Type.EmptyRecord -> return tipe

50− Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext

51+ Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext

51− where rnm' (f,t) = (,) f `liftM` rnm t

52+ where rnm' (f,t) = (,) f <$> rnm t

52

53

53−metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)

54+metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

54metadataModule ifaces modul =

55metadataModule ifaces modul =

55 do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

56 do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

56 [] -> Right ()

57 [] -> Right ()

57 missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

58 missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

58 program' <- rename initialEnv (program modul)

59 program' <- rename initialEnv (program modul)

59− aliases' <- mapM (threeOfFour renameType') (aliases modul)

60+ aliases' <- mapM (three4 renameType') (aliases modul)

60− datatypes' <- mapM (threeOfFour (mapM (two2 (mapM renameType')))) (datatypes modul)

61+ datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)

61− ports' <- mapM (two3 renameType') (ports modul)

62+ sendPorts' <- mapM (three3 renameType') (sendPorts modul)

63+ recvPorts' <- mapM (three3 renameType') (recvPorts modul)

62 return $ modul { program = program'

64 return $ modul { program = program'

63 , aliases = aliases'

65 , aliases = aliases'

64 , datatypes = datatypes'

66 , datatypes = datatypes'

65− , ports = ports' }

67+ , sendPorts = sendPorts'

68+ , recvPorts = recvPorts' }

66 where

69 where

67− two2 f (a,b) = (,) a `fmap` f b

70+ two2 f (a,b) = (,) a <$> f b

68− two3 f (a,b,c) = (,,) a `fmap` f b `ap` return c

71+ three3 f (a,b,c) = (,,) a b <$> f c

69− threeOfFour f (a,b,c,d) = (,,,) a b `fmap` f c `ap` return d

72+ three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d

70 twoAndFour f g (a,b,c,d) =

73 twoAndFour f g (a,b,c,d) =

71 do b' <- f b

74 do b' <- f b

72 d' <- g d

75 d' <- g d

97

100

98type Env = Map.Map String String

101type Env = Map.Map String String

99

102

100−extend :: Env -> Pattern -> Env

103+extend :: Env -> P.Pattern -> Env

101extend env pattern = Map.union (Map.fromList (zip xs xs)) env

104extend env pattern = Map.union (Map.fromList (zip xs xs)) env

102− where xs = Set.toList (SD.boundVars pattern)

105+ where xs = Set.toList (P.boundVars pattern)

103

106

104

107

105replace :: String -> Env -> String -> Either String String

108replace :: String -> Env -> String -> Either String String

113 msg = if null matches then "" else

116 msg = if null matches then "" else

114 "\nClose matches include: " ++ List.intercalate ", " matches

117 "\nClose matches include: " ++ List.intercalate ", " matches

115

118

116−rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)

119+rename :: Env -> LExpr -> Either [Doc] LExpr

117rename env lexpr@(L s expr) =

120rename env lexpr@(L s expr) =

118 let rnm = rename env

121 let rnm = rename env

119 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

122 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

120 format = Either.either throw return

123 format = Either.either throw return

121 in

124 in

122− L s `liftM`

125+ L s <$>

123 case expr of

126 case expr of

124 Literal lit -> return expr

127 Literal lit -> return expr

125

128

126− Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2

129+ Range e1 e2 -> Range <$> rnm e1 <*> rnm e2

127

130

128− Access e x -> Access `liftM` rnm e `ap` return x

131+ Access e x -> Access <$> rnm e <*> return x

129

132

130− Remove e x -> flip Remove x `liftM` rnm e

133+ Remove e x -> flip Remove x <$> rnm e

131

134

132− Insert e x v -> flip Insert x `liftM` rnm e `ap` rnm v

135+ Insert e x v -> flip Insert x <$> rnm e <*> rnm v

133

136

134 Modify e fs ->

137 Modify e fs ->

135− Modify `liftM` rnm e `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs

138+ Modify <$> rnm e <*> mapM (\(x,e) -> (,) x <$> rnm e) fs

136

139

137− Record fs -> Record `liftM` mapM frnm fs

140+ Record fs -> Record <$> mapM frnm fs

138 where

141 where

139− frnm (f,e) = (,) f `liftM` rename env e

142+ frnm (f,e) = (,) f <$> rename env e

140

143

141 Binop op e1 e2 ->

144 Binop op e1 e2 ->

142 do op' <- format (replace "variable" env op)

145 do op' <- format (replace "variable" env op)

143− Binop op' `liftM` rnm e1 `ap` rnm e2

146+ Binop op' <$> rnm e1 <*> rnm e2

144

147

145 Lambda pattern e ->

148 Lambda pattern e ->

146 let env' = extend env pattern in

149 let env' = extend env pattern in

147− Lambda `liftM` format (renamePattern env' pattern) `ap` rename env' e

150+ Lambda <$> format (renamePattern env' pattern) <*> rename env' e

148

151

149− App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2

152+ App e1 e2 -> App <$> rnm e1 <*> rnm e2

150

153

151− MultiIf ps -> MultiIf `liftM` mapM grnm ps

154+ MultiIf ps -> MultiIf <$> mapM grnm ps

152− where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e

155+ where grnm (b,e) = (,) <$> rnm b <*> rnm e

153

156

154− Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e

157+ Let defs e -> Let <$> mapM rename' defs <*> rename env' e

155 where

158 where

156− env' = foldl extend env [ pattern | Def pattern _ <- defs ]

159+ env' = foldl extend env $ map (\(Definition p _ _) -> p) defs

157− rename' def =

160+ rename' (Definition p exp mtipe) =

161+ Definition <$> format (renamePattern env' p)

162+ <*> rename env' exp

158− case def of

163+ <*> case mtipe of

159− Def p exp ->

164+ Nothing -> return Nothing

160− Def `liftM` format (renamePattern env' p) `ap` rename env' exp

161− TypeAnnotation name tipe ->

162− TypeAnnotation name `liftM`

163− renameType (format . replace "variable" env') tipe

165+ Just tipe -> Just <$> renameType (format . replace "variable" env') tipe

164

166

165− Var x -> Var `liftM` format (replace "variable" env x)

167+ Var x -> Var <$> format (replace "variable" env x)

166

168

167− Data name es -> Data name `liftM` mapM rnm es

169+ Data name es -> Data name <$> mapM rnm es

168

170

169− ExplicitList es -> ExplicitList `liftM` mapM rnm es

171+ ExplicitList es -> ExplicitList <$> mapM rnm es

170

172

171− Case e cases -> Case `liftM` rnm e `ap` mapM branch cases

173+ Case e cases -> Case <$> rnm e <*> mapM branch cases

172 where

174 where

173− branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)

175+ branch (pattern,e) = (,) <$> format (renamePattern env pattern)

174− `ap` rename (extend env pattern) e

176+ <*> rename (extend env pattern) e

175

177

176− Markdown uid md es -> Markdown uid md `liftM` mapM rnm es

178+ Markdown uid md es -> Markdown uid md <$> mapM rnm es

177

179

178

180

179−renamePattern :: Env -> Pattern -> Either String Pattern

181+renamePattern :: Env -> P.Pattern -> Either String P.Pattern

180renamePattern env pattern =

182renamePattern env pattern =

181 case pattern of

183 case pattern of

182− PVar _ -> return pattern

184+ P.PVar _ -> return pattern

183− PLiteral _ -> return pattern

185+ P.PLiteral _ -> return pattern

184− PRecord _ -> return pattern

186+ P.PRecord _ -> return pattern

185− PAnything -> return pattern

187+ P.PAnything -> return pattern

186− PAlias x p -> PAlias x `liftM` renamePattern env p

188+ P.PAlias x p -> P.PAlias x <$> renamePattern env p

187− PData name ps -> PData `liftM` replace "pattern" env name

189+ P.PData name ps -> P.PData <$> replace "pattern" env name

188− `ap` mapM (renamePattern env) ps

190+ <*> mapM (renamePattern env) ps