@@ -0,0 +1,187 @@
1+module Transform.Canonicalize (interface, metadataModule) where
2+
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
17+
18+-- todo: remove these
19+import System.IO.Unsafe
20+import SourceSyntax.PrettyPrint
21+
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
29+ return x
30+ in f $
31+ ModuleInterface {
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)
35+ }
36+ where
37+ both f g (a,b,c) = (f a, b, g c)
38+ prefix name = moduleName ++ "." ++ name
39+
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) ]
44+
45+ renameCtors ctors =
46+ map (prefix *** map renameType') ctors
47+ renameType' =
48+ runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
49+
50+renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type
51+renameType rename tipe =
52+ let rnm = renameType rename in
53+ case tipe of
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
60+
61+metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)
62+metadataModule ifaces modul =
63+ do let f x = unsafePerformIO $ do
64+ print realImports
65+ print ifaces
66+ putStr "initialEnv " >> print initialEnv
67+ return x
68+ program' <- f $ rename initialEnv (program modul)
69+ return $ modul { program = program' }
70+ where
71+ get1 (a,_,_) = a
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
85+ print vs
86+ print allNames
87+ print y
88+ return y
89+
90+ pair n = (n,n)
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)
96+
97+
98+type Env = Map.Map String String
99+
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)
103+
104+
105+replace :: Env -> String -> Either String String
106+replace env v =
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
111+ where
112+ matches = filter (List.isInfixOf v) (Map.keys env)
113+ msg = if null matches then "" else
114+ "\nClose matches include: " ++ List.intercalate ", " matches
115+
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
121+ in
122+ L t s `liftM`
123+ case expr of
124+ Literal lit -> return expr
125+
126+ Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2
127+
128+ Access e x -> Access `liftM` rnm e `ap` return x
129+
130+ Remove e x -> flip Remove x `liftM` rnm e
131+
132+ Insert e x v -> flip Insert x `liftM` rnm e `ap` rnm v
133+
134+ Modify e fs ->
135+ Modify `liftM` rnm e `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
136+
137+ Record fs -> Record `liftM` mapM frnm fs
138+ where
139+ frnm (f,e) = (,) f `liftM` rename env e
140+
141+ Binop op e1 e2 ->
142+ do op' <- if isOp op then return op else format (replace env op)
143+ Binop op' `liftM` rnm e1 `ap` rnm e2
144+
145+ Lambda pattern e ->
146+ let env' = extend env pattern in
147+ Lambda pattern `liftM` rename env' e
148+
149+ App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2
150+
151+ MultiIf ps -> MultiIf `liftM` mapM grnm ps
152+ where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e
153+
154+ Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e
155+ 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` renameType (format . replace env') tipe
163+
164+ Var x -> Var `liftM` format (replace env x)
165+
166+ Data name es -> Data name `liftM` mapM rnm es
167+
168+ ExplicitList es -> ExplicitList `liftM` mapM rnm es
169+
170+ Case e cases -> Case `liftM` rnm e `ap` mapM branch cases
171+ where
172+ branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)
173+ `ap` rename (extend env pattern) e
174+
175+ Markdown _ -> return expr
176+
177+
178+renamePattern :: Env -> Pattern -> Either String Pattern
179+renamePattern env pattern =
180+ case pattern of
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