@@ -0,0 +1,187 @@
1+module Transform.Canonicalize (interface, metadataModule) where
3+import Control.Arrow (first, second, (***))
4+import Control.Monad.Identity
5+import qualified Data.Map as Map
6+import qualified Data.Set as Set
7+import qualified Data.List as List
8+import qualified Data.Either as Either
9+import SourceSyntax.Module
10+import SourceSyntax.Expression
11+import SourceSyntax.Location as Loc
12+import SourceSyntax.Pattern
13+import SourceSyntax.Helpers (isOp)
14+import qualified SourceSyntax.Type as Type
15+import qualified Transform.SortDefinitions as SD
16+import Text.PrettyPrint
19+import System.IO.Unsafe
20+import SourceSyntax.PrettyPrint
22+interface :: String -> ModuleInterface -> ModuleInterface
23+interface moduleName iface =
24+ let f x = unsafePerformIO $ do
25+ putStrLn "----------------------\ncanonicalize interface"
26+ putStr "iface " >> print iface
27+ putStr "canons " >> print canons
28+ putStr "iface' " >> print x
32+ iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface)),
33+ iAdts = map (both prefix renameCtors) (iAdts iface),
34+ iAliases = map (both prefix renameType') (iAliases iface)
37+ both f g (a,b,c) = (f a, b, g c)
38+ prefix name = moduleName ++ "." ++ name
40+ pair name = (name, moduleName ++ "." ++ name)
41+ canon (name,_,_) = pair name
42+ canons = Map.fromList $ concat
43+ [ map canon (iAdts iface), map canon (iAliases iface) ]
46+ map (prefix *** map renameType') ctors
48+ runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
50+renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type
51+renameType rename tipe =
52+ let rnm = renameType rename in
54+ Type.Lambda a b -> Type.Lambda `liftM` rnm a `ap` rnm b
55+ Type.Var x -> return tipe
56+ Type.Data name ts -> Type.Data `liftM` rename name `ap` mapM rnm ts
57+ Type.EmptyRecord -> return tipe
58+ Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext
59+ where rnm' (f,t) = (,) f `liftM` rnm t
61+metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)
62+metadataModule ifaces modul =
63+ do let f x = unsafePerformIO $ do
66+ putStr "initialEnv " >> print initialEnv
68+ program' <- f $ rename initialEnv (program modul)
69+ return $ modul { program = program' }
72+ canon (name, importMethod) =
73+ let pair pre var = (pre ++ drop (length name + 1) var, var)
74+ iface = ifaces Map.! name
75+ allNames = concat [ Map.keys (iTypes iface)
76+ , map get1 (iAliases iface)
77+ , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]
78+ in case importMethod of
79+ As alias -> map (pair (alias ++ ".")) allNames
80+ Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames
81+ where vs = Set.fromList vars
82+ Importing vars -> f $ map (pair "") $ filter (flip Set.member vs) allNames
83+ where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
84+ f y = unsafePerformIO $ do
91+ localEnv = concat [ map (pair . get1) (aliases modul)
92+ , map (pair . get1) (datatypes modul) ]
93+ globalEnv = map pair $ [ saveEnvName, "::", "[]" ] ++ map (\n -> "_Tuple" ++ show n) [0..9]
94+ realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
95+ initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
98+type Env = Map.Map String String
100+extend :: Env -> Pattern -> Env
101+extend env pattern = Map.union (Map.fromList (zip xs xs)) env
102+ where xs = Set.toList (SD.boundVars pattern)
105+replace :: Env -> String -> Either String String
107+ if List.isPrefixOf "Native." v then return v else
108+ case Map.lookup v env of
109+ Just v' -> return v'
110+ Nothing -> Left $ "Could not find variable '" ++ v ++ "'." ++ msg
112+ matches = filter (List.isInfixOf v) (Map.keys env)
113+ msg = if null matches then "" else
114+ "\nClose matches include: " ++ List.intercalate ", " matches
116+rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)
117+rename env lexpr@(L t s expr) =
118+ let rnm = rename env
119+ throw err = Left [ text $ "Error " ++ show s ++ "\n" ++ err ]
120+ format = Either.either throw return
124+ Literal lit -> return expr
126+ Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2
128+ Access e x -> Access `liftM` rnm e `ap` return x
130+ Remove e x -> flip Remove x `liftM` rnm e
132+ Insert e x v -> flip Insert x `liftM` rnm e `ap` rnm v
135+ Modify `liftM` rnm e `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
137+ Record fs -> Record `liftM` mapM frnm fs
139+ frnm (f,e) = (,) f `liftM` rename env e
142+ do op' <- if isOp op then return op else format (replace env op)
143+ Binop op' `liftM` rnm e1 `ap` rnm e2
146+ let env' = extend env pattern in
147+ Lambda pattern `liftM` rename env' e
149+ App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2
151+ MultiIf ps -> MultiIf `liftM` mapM grnm ps
152+ where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e
154+ Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e
156+ env' = foldl extend env [ pattern | Def pattern _ <- defs ]
160+ Def `liftM` format (renamePattern env' p) `ap` rename env' exp
161+ TypeAnnotation name tipe ->
162+ TypeAnnotation name `liftM` renameType (format . replace env') tipe
164+ Var x -> Var `liftM` format (replace env x)
166+ Data name es -> Data name `liftM` mapM rnm es
168+ ExplicitList es -> ExplicitList `liftM` mapM rnm es
170+ Case e cases -> Case `liftM` rnm e `ap` mapM branch cases
172+ branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)
173+ `ap` rename (extend env pattern) e
175+ Markdown _ -> return expr
178+renamePattern :: Env -> Pattern -> Either String Pattern
179+renamePattern env pattern =
181+ PVar _ -> return pattern
182+ PLiteral _ -> return pattern
183+ PRecord _ -> return pattern
184+ PAnything -> return pattern
185+ PAlias x p -> PAlias x `liftM` renamePattern env p
186+ PData name ps -> PData `liftM` replace env name
187+ `ap` mapM (renamePattern env) ps