@@ -1,6 +1,7 @@
11module Transform.Canonicalize (interface, metadataModule) where
22
33import Control.Arrow ((***))
4+import Control.Applicative (Applicative,(<$>),(<*>))
45import Control.Monad.Identity
56import qualified Data.Map as Map
67import qualified Data.Set as Set
@@ -9,7 +10,7 @@ import qualified Data.Either as Either
910import SourceSyntax.Module
1011import SourceSyntax.Expression
1112import SourceSyntax.Location as Loc
12−import SourceSyntax.Pattern
13+import qualified SourceSyntax.Pattern as P
1314import SourceSyntax.Helpers (isOp)
1415import qualified SourceSyntax.Type as Type
1516import qualified Transform.SortDefinitions as SD
@@ -39,34 +40,36 @@ interface moduleName iface =
3940 renameType' =
4041 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
4142
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
4344renameType rename tipe =
4445 let rnm = renameType rename in
4546 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
4748 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
4950 Type.EmptyRecord -> return tipe
50− Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext
51− where rnm' (f,t) = (,) f `liftM` rnm t
51+ Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext
52+ where rnm' (f,t) = (,) f <$> rnm t
5253
53−metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)
54+metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
5455metadataModule ifaces modul =
5556 do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
5657 [] -> Right ()
5758 missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
5859 program' <- rename initialEnv (program modul)
59− aliases' <- mapM (threeOfFour renameType') (aliases modul)
60− datatypes' <- mapM (threeOfFour (mapM (two2 (mapM renameType')))) (datatypes modul)
61− ports' <- mapM (two3 renameType') (ports modul)
60+ aliases' <- mapM (three4 renameType') (aliases modul)
61+ datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)
62+ sendPorts' <- mapM (three3 renameType') (sendPorts modul)
63+ recvPorts' <- mapM (three3 renameType') (recvPorts modul)
6264 return $ modul { program = program'
6365 , aliases = aliases'
6466 , datatypes = datatypes'
65− , ports = ports' }
67+ , sendPorts = sendPorts'
68+ , recvPorts = recvPorts' }
6669 where
67− two2 f (a,b) = (,) a `fmap` f b
68− two3 f (a,b,c) = (,,) a `fmap` f b `ap` return c
69− threeOfFour f (a,b,c,d) = (,,,) a b `fmap` f c `ap` return d
70+ two2 f (a,b) = (,) a <$> f b
71+ three3 f (a,b,c) = (,,) a b <$> f c
72+ three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d
7073 twoAndFour f g (a,b,c,d) =
7174 do b' <- f b
7275 d' <- g d
@@ -97,9 +100,9 @@ metadataModule ifaces modul =
97100
98101type Env = Map.Map String String
99102
100−extend :: Env -> Pattern -> Env
103+extend :: Env -> P.Pattern -> Env
101104extend 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)
103106
104107
105108replace :: String -> Env -> String -> Either String String
@@ -113,76 +116,75 @@ replace variable env v =
113116 msg = if null matches then "" else
114117 "\nClose matches include: " ++ List.intercalate ", " matches
115118
116−rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)
119+rename :: Env -> LExpr -> Either [Doc] LExpr
117120rename env lexpr@(L s expr) =
118121 let rnm = rename env
119122 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
120123 format = Either.either throw return
121124 in
122− L s `liftM`
125+ L s <$>
123126 case expr of
124127 Literal lit -> return expr
125128
126− Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2
129+ Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
127130
128− Access e x -> Access `liftM` rnm e `ap` return x
131+ Access e x -> Access <$> rnm e <*> return x
129132
130− Remove e x -> flip Remove x `liftM` rnm e
133+ Remove e x -> flip Remove x <$> rnm e
131134
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
133136
134137 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
136139
137− Record fs -> Record `liftM` mapM frnm fs
140+ Record fs -> Record <$> mapM frnm fs
138141 where
139− frnm (f,e) = (,) f `liftM` rename env e
142+ frnm (f,e) = (,) f <$> rename env e
140143
141144 Binop op e1 e2 ->
142145 do op' <- format (replace "variable" env op)
143− Binop op' `liftM` rnm e1 `ap` rnm e2
146+ Binop op' <$> rnm e1 <*> rnm e2
144147
145148 Lambda pattern e ->
146149 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
148151
149− App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2
152+ App e1 e2 -> App <$> rnm e1 <*> rnm e2
150153
151− MultiIf ps -> MultiIf `liftM` mapM grnm ps
152− where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e
154+ MultiIf ps -> MultiIf <$> mapM grnm ps
155+ where grnm (b,e) = (,) <$> rnm b <*> rnm e
153156
154− Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e
157+ Let defs e -> Let <$> mapM rename' defs <*> rename env' e
155158 where
156− env' = foldl extend env [ pattern | Def pattern _ <- defs ]
157− rename' def =
158− case def of
159− Def p exp ->
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
159+ env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
160+ rename' (Definition p exp mtipe) =
161+ Definition <$> format (renamePattern env' p)
162+ <*> rename env' exp
163+ <*> case mtipe of
164+ Nothing -> return Nothing
165+ Just tipe -> Just <$> renameType (format . replace "variable" env') tipe
164166
165− Var x -> Var `liftM` format (replace "variable" env x)
167+ Var x -> Var <$> format (replace "variable" env x)
166168
167− Data name es -> Data name `liftM` mapM rnm es
169+ Data name es -> Data name <$> mapM rnm es
168170
169− ExplicitList es -> ExplicitList `liftM` mapM rnm es
171+ ExplicitList es -> ExplicitList <$> mapM rnm es
170172
171− Case e cases -> Case `liftM` rnm e `ap` mapM branch cases
173+ Case e cases -> Case <$> rnm e <*> mapM branch cases
172174 where
173− branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)
174− `ap` rename (extend env pattern) e
175+ branch (pattern,e) = (,) <$> format (renamePattern env pattern)
176+ <*> rename (extend env pattern) e
175177
176− Markdown uid md es -> Markdown uid md `liftM` mapM rnm es
178+ Markdown uid md es -> Markdown uid md <$> mapM rnm es
177179
178180
179−renamePattern :: Env -> Pattern -> Either String Pattern
181+renamePattern :: Env -> P.Pattern -> Either String P.Pattern
180182renamePattern env pattern =
181183 case pattern of
182− PVar _ -> return pattern
183− PLiteral _ -> return pattern
184− PRecord _ -> return pattern
185− PAnything -> return pattern
186− PAlias x p -> PAlias x `liftM` renamePattern env p
187− PData name ps -> PData `liftM` replace "pattern" env name
188− `ap` mapM (renamePattern env) ps
184+ P.PVar _ -> return pattern
185+ P.PLiteral _ -> return pattern
186+ P.PRecord _ -> return pattern
187+ P.PAnything -> return pattern
188+ P.PAlias x p -> P.PAlias x <$> renamePattern env p
189+ P.PData name ps -> P.PData <$> replace "pattern" env name
190+ <*> mapM (renamePattern env) ps