@@ -1,191 +1,339 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Transform.Canonicalize (interface, metadataModule) where
1+{-# OPTIONS_GHC -W #-}
2+module Transform.Canonicalize {-(interface, metadataModule)-} where
33
4−import Control.Arrow ((***))
5−import Control.Applicative (Applicative,(<$>),(<*>))
6−import Control.Monad.Identity
4+import Control.Applicative ((<$>),(<*>))
5+import Control.Arrow (first)
6+import Control.Monad (foldM)
77import qualified Data.Either as Either
88import qualified Data.List as List
9+import Data.Map ((!))
910import qualified Data.Map as Map
10−import qualified Data.Set as Set
1111import qualified Data.Traversable as T
12−import SourceSyntax.Annotation as A
13−import SourceSyntax.Expression
14−import SourceSyntax.Module
15−import SourceSyntax.PrettyPrint (pretty)
16−import qualified SourceSyntax.Pattern as P
17−import qualified SourceSyntax.Type as Type
18−import qualified SourceSyntax.Variable as Var
12+
13+import AST.Expression.General (Expr'(..), dummyLet)
14+import qualified AST.Expression.Valid as Valid
15+import qualified AST.Expression.Canonical as Canonical
16+
17+import AST.Module (Interfaces, Interface(..), Module(..), CanonicalBody(..), ImportMethod)
18+import qualified AST.Module as Module
19+import qualified AST.Type as Type
20+import qualified AST.Variable as Var
21+import qualified AST.Annotation as A
22+import AST.Declaration as D
23+import AST.PrettyPrint (pretty, commaSep)
24+import qualified AST.Pattern as P
1925import Text.PrettyPrint as P
2026
21−interface :: String -> ModuleInterface -> ModuleInterface
22−interface moduleName iface =
23− ModuleInterface
24− { iVersion = iVersion iface
25− , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))
26− , iImports = iImports iface
27− , iAdts = map (both prefix renameCtors) (iAdts iface)
28− , iAliases = map (both prefix renameType') (iAliases iface)
29− , iFixities = iFixities iface -- cannot have canonicalized operators while parsing
30− , iPorts = iPorts iface
31− }
32− where
33− both f g (a,b,c) = (f a, b, g c)
34− prefix name = moduleName ++ "." ++ name
35−
36− pair name = (name, moduleName ++ "." ++ name)
37− canon (name,_,_) = pair name
38− canons = Map.fromList $ concat
39− [ map canon (iAdts iface), map canon (iAliases iface) ]
40−
41− renameCtors ctors =
42− map (prefix *** map renameType') ctors
43− renameType' =
44− runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
45−
46−renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type
47−renameType renamer tipe =
48− let rnm = renameType renamer in
49− case tipe of
50− Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
51− Type.Var _ -> return tipe
52− Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
53− Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext
54− where rnm' (f,t) = (,) f <$> rnm t
55−
56−metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
57−metadataModule ifaces modul =
58− do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
59− [] -> Right ()
60− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ++
61− "\n You may need to compile with the --make flag to detect modules you have written."
62− ]
63− program' <- rename initialEnv (program modul)
64− aliases' <- mapM (three3 renameType') (aliases modul)
65− datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)
66− return $ modul { program = program'
67− , aliases = aliases'
68− , datatypes = datatypes' }
27+import Transform.Canonicalize.Environment
28+import Transform.Canonicalize.Type
29+import Transform.Canonicalize.Variable (variable, pvar)
30+import qualified Transform.SortDefinitions as Transform
31+import qualified Transform.Declaration as Transform
32+
33+environment :: Interfaces -> Module.ValidModule -> Either [Doc] Environment
34+environment interfaces (Module.Module _ _ _ ims decls) =
35+ do () <- allImportsAvailable interfaces ims
36+ nonLocalEnv <- foldM (toEnv interfaces) builtIns ims
37+ foldM (flip addDecl) nonLocalEnv decls
38+
39+toEnv :: Interfaces -> Environment -> (String, ImportMethod) -> Either [Doc] Environment
40+toEnv interfaces environ (name,method) =
41+ case method of
42+ Module.As name' ->
43+ return (env (name' ++ "."))
44+
45+ Module.Open (Var.Listing vs open)
46+ | open -> return (env "")
47+ | otherwise -> foldM (addValue name interface) environ vs
48+ where
49+ interface = interfaces ! name
50+
51+ env prefix =
52+ let dict' = dict . map (first (prefix++)) in
53+ Env { _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
54+ , _adts = dict' $ map pair (Map.keys (iAdts interface))
55+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))
56+ , _patterns = dict' $ ctors
57+ }
58+
59+ canonical :: String -> Var.Canonical
60+ canonical = Var.Canonical (Var.Module name)
61+
62+ pair :: String -> (String, Var.Canonical)
63+ pair key = (key, canonical key)
64+
65+ alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
66+
67+ ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
68+
69+addValue :: String -> Module.Interface -> Environment -> Var.Value
70+ -> Either [Doc] Environment
71+addValue name interface env value =
72+ let insert' x = insert x (Var.Canonical (Var.Module name) x)
73+ notFound x = Left [ P.text $
74+ "Import Error: Could not import value '" ++ name ++ "." ++ x ++ "'.\n" ++
75+ " It is not exported by module " ++ name ++ "." ]
76+ in
77+ case value of
78+ Var.Value x
79+ | Map.notMember x (iTypes interface) -> notFound x
80+ | otherwise ->
81+ return $ env { _values = insert' x (_values env) }
82+
83+ Var.Alias x ->
84+ case Map.lookup x (iAliases interface) of
85+ Nothing -> notFound x
86+ Just (tvars, t) ->
87+ let v = (Var.Canonical (Var.Module name) x, tvars, t) in
88+ return $ env { _aliases = insert x v (_aliases env) }
89+
90+ Var.ADT x (Var.Listing xs open) ->
91+ case Map.lookup x (iAdts interface) of
92+ Nothing -> notFound x
93+ Just (_tvars, ctors) ->
94+ do ctors <- filterNames (map fst ctors)
95+ return $ env { _adts = insert' x (_adts env)
96+ , _values = foldr insert' (_values env) ctors
97+ , _patterns = foldr insert' (_patterns env) ctors
98+ }
99+ where
100+ filterNames names
101+ | open = return names
102+ | otherwise =
103+ case filter (`notElem` names) xs of
104+ [] -> return names
105+ c:_ -> notFound c
106+
107+addDecl :: D.ValidDecl -> Environment -> Either [Doc] Environment
108+addDecl decl env =
109+ case decl of
110+ D.Definition (Valid.Definition pattern _ _) ->
111+ return $ env
112+ { _values = foldr add (_values env) (P.boundVarList pattern) }
113+ where
114+ add x e = insert x (Var.local x) e
115+
116+ D.Datatype name _ ctors ->
117+ return $ env
118+ { _values = addCtors (_values env)
119+ , _adts = insert name (Var.local name) (_adts env)
120+ , _patterns = addCtors (_patterns env)
121+ }
122+ where
123+ addCtors e = foldr add e (map fst ctors)
124+ add name e = insert name (Var.local name) e
125+
126+ D.TypeAlias name tvars alias ->
127+ do alias' <- Either.either throw return (tipe env alias)
128+ return $ env
129+ { _aliases = insert name (Var.local name, tvars, alias') (_aliases env)
130+ , _values = case alias of
131+ Type.Record _ _ -> insert name (Var.local name) (_values env)
132+ _ -> _values env
133+ }
134+ where
135+ throw err = Left [ P.vcat [ P.text $ "Error in type alias '" ++ name ++ "':"
136+ , P.text err
137+ ]
138+ ]
139+
140+ D.Port _ -> return env
141+
142+ D.Fixity _ _ _ -> return env
143+
144+module' :: Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule
145+module' interfaces modul@(Module.Module _ _ exs _ decls) =
146+ do env <- environment interfaces modul
147+ canonicalDecls <- mapM (declaration env) decls
148+ exports' <- delist locals exs
149+ return $ modul { exports = exports'
150+ , body = body canonicalDecls
151+ }
69152 where
70− two2 f (a,b) = (,) a <$> f b
71− three3 f (a,b,c) = (,,) a b <$> f c
72− renameType' =
73− Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
74−
75− get1 (a,_,_) = a
76− canon (name, importMethod) =
77− let pair pre var = (pre ++ drop (length name + 1) var, var)
78− iface = ifaces Map.! name
79− allNames = concat [ Map.keys (iTypes iface)
80− , map get1 (iAliases iface)
81− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]
82− in case importMethod of
83− As alias -> map (pair (alias ++ ".")) allNames
84− Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames
85− where vs = Set.fromList vars
86− Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
87− where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
88−
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]
94− realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
95− initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
96−
97−type Env = Map.Map String String
98−
99−extend :: Env -> P.Pattern -> Env
100−extend env pattern = Map.union (Map.fromList (zip xs xs)) env
101− where xs = P.boundVarList pattern
102−
103−replace :: String -> Env -> String -> Either String String
104−replace variable env v =
105− if List.isPrefixOf "Native." v then return v else
106− case Map.lookup v env of
107− Just v' -> return v'
108− Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg
153+ locals :: [Var.Value]
154+ locals = concatMap declToValue decls
155+
156+ body :: [D.CanonicalDecl] -> CanonicalBody
157+ body decls =
158+ CanonicalBody
159+ { program = Transform.sortDefs . dummyLet $ Transform.toExpr decls
160+ , types = Map.empty
161+ , datatypes = Map.fromList [ (name,(vars,ctors)) | Datatype name vars ctors <- decls ]
162+ , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]
163+ , aliases = Map.fromList [ (name,(tvs,alias)) | TypeAlias name tvs alias <- decls ]
164+ , ports = [ portName port | Port port <- decls ]
165+ }
166+
167+delist :: [Var.Value] -> Var.Listing Var.Value -> Either [Doc] [Var.Value]
168+delist fullList (Var.Listing partial open)
169+ | open = return fullList
170+ | otherwise = go [] (List.sort fullList) (List.sort partial)
171+ where
172+ notFound xs =
173+ Left $ [ P.text "Export Error: trying to export non-existent values:" <+>
174+ commaSep (map pretty xs)
175+ ]
176+
177+ go list full partial =
178+ case (full, partial) of
179+ (_, []) -> return list
180+ ([], _) -> notFound partial
181+ (x:xs, y:ys) ->
182+ case (x,y) of
183+ (Var.Value x', Var.Value y') | x' == y' ->
184+ go (x : list) xs ys
185+
186+ (Var.Alias x', Var.Alias y') | x' == y' ->
187+ go (x : list) xs ys
188+
189+ (Var.ADT x' (Var.Listing xctors _ ),
190+ Var.ADT y' (Var.Listing yctors open)) | x' == y' ->
191+ if open
192+ then go (x : list) xs ys
193+ else case filter (`notElem` xctors) yctors of
194+ [] -> go (y : list) xs ys
195+ bads -> notFound bads
196+
197+ _ -> go list xs partial
198+
199+declToValue :: D.ValidDecl -> [Var.Value]
200+declToValue decl =
201+ case decl of
202+ D.Definition (Valid.Definition pattern _ _) ->
203+ map Var.Value (P.boundVarList pattern)
204+
205+ D.Datatype name _tvs ctors ->
206+ [ Var.ADT name (Var.Listing (map fst ctors) False) ]
207+
208+ D.TypeAlias name _ (Type.Record _ _) ->
209+ [ Var.Alias name ]
210+
211+ _ -> []
212+
213+declaration :: Environment -> D.ValidDecl -> Either [Doc] D.CanonicalDecl
214+declaration env decl =
215+ let canonicalize kind context pattern env v =
216+ case kind env v of
217+ Right v' -> Right v'
218+ Left err -> Left [ P.vcat [ ctx, P.text err ] ]
219+ where ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon
220+ in
221+ case decl of
222+ D.Definition (Valid.Definition p e t) ->
223+ do p' <- canonicalize pattern "definition" p env p
224+ e' <- expression env e
225+ t' <- T.traverse (canonicalize tipe "definition" p env) t
226+ return $ D.Definition (Canonical.Definition p' e' t')
227+
228+ D.Datatype name tvars ctors ->
229+ D.Datatype name tvars <$> mapM canonicalize' ctors
109230 where
110− matches = filter (List.isInfixOf v) (Map.keys env)
111− msg = if null matches then "" else
112− "\nClose matches include: " ++ List.intercalate ", " matches
113−
114−-- TODO: Var.Raw -> Var.Canonical
115−rename :: Env -> Expr -> Either [Doc] Expr
116−rename env (A ann expr) =
117− let rnm = rename env
231+ canonicalize' (ctor,args) =
232+ (,) ctor <$> mapM (canonicalize tipe "datatype" name env) args
233+
234+ D.TypeAlias name tvars expanded ->
235+ D.TypeAlias name tvars <$> canonicalize tipe "type alias" name env expanded
236+
237+ D.Port port ->
238+ D.Port <$> case port of
239+ D.In name t -> D.In name <$> canonicalize tipe "port" name env t
240+ D.Out name e t ->
241+ do e' <- expression env e
242+ t' <- canonicalize tipe "port" name env t
243+ return (D.Out name e' t')
244+
245+ D.Fixity assoc prec op -> return $ D.Fixity assoc prec op
246+
247+
248+allImportsAvailable :: Interfaces -> [(String,ImportMethod)] -> Either [Doc] ()
249+allImportsAvailable interfaces imports =
250+ case filter (`Map.notMember` interfaces) modules of
251+ [] -> Right ()
252+ missings -> Left [ P.text (missingModuleError missings) ]
253+ where
254+ modules = map fst imports
255+
256+ missingModuleError missings =
257+ concat [ "The following imports were not found: "
258+ , List.intercalate ", " missings
259+ , "\n You may need to compile with the --make "
260+ , "flag to detect modules you have written." ]
261+
262+expression :: Environment -> Valid.Expr -> Either [Doc] Canonical.Expr
263+expression env (A.A ann expr) =
264+ let go = expression env
265+ tipe' environ = format . tipe environ
118266 throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon
119267 , P.text err
120268 ]
121269 ]
122270 format = Either.either throw return
123− renameType' environ = renameType (format . replace "variable" environ)
124271 in
125− A ann <$>
272+ A.A ann <$>
126273 case expr of
127− Literal _ -> return expr
274+ Literal lit -> return (Literal lit)
128275
129− Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
276+ Range e1 e2 -> Range <$> go e1 <*> go e2
130277
131− Access e x -> Access <$> rnm e <*> return x
278+ Access e x -> Access <$> go e <*> return x
132279
133− Remove e x -> flip Remove x <$> rnm e
280+ Remove e x -> flip Remove x <$> go e
134281
135− Insert e x v -> flip Insert x <$> rnm e <*> rnm v
282+ Insert e x v -> flip Insert x <$> go e <*> go v
136283
137284 Modify e fs ->
138− Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs
285+ Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs
139286
140− Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs
287+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fs
141288
142− Binop op e1 e2 ->
143− do op' <- format (replace "variable" env op)
144− Binop op' <$> rnm e1 <*> rnm e2
289+ Binop (Var.Raw op) e1 e2 ->
290+ do op' <- format (variable env op)
291+ Binop op' <$> go e1 <*> go e2
145292
146− Lambda pattern e ->
147− let env' = extend env pattern in
148− Lambda <$> format (renamePattern env' pattern) <*> rename env' e
293+ Lambda p e ->
294+ let env' = update p env in
295+ Lambda <$> format (pattern env' p) <*> expression env' e
149296
150− App e1 e2 -> App <$> rnm e1 <*> rnm e2
297+ App e1 e2 -> App <$> go e1 <*> go e2
151298
152− MultiIf ps -> MultiIf <$> mapM grnm ps
153− where grnm (b,e) = (,) <$> rnm b <*> rnm e
299+ MultiIf ps -> MultiIf <$> mapM go' ps
300+ where go' (b,e) = (,) <$> go b <*> go e
154301
155− Let defs e -> Let <$> mapM rename' defs <*> rename env' e
302+ Let defs e -> Let <$> mapM rename' defs <*> expression env' e
156303 where
157− env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
158− rename' (Definition p body mtipe) =
159− Definition <$> format (renamePattern env' p)
160− <*> rename env' body
161− <*> T.traverse (renameType' env') mtipe
304+ env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs
305+ rename' (Valid.Definition p body mtipe) =
306+ Canonical.Definition
307+ <$> format (pattern env' p)
308+ <*> expression env' body
309+ <*> T.traverse (tipe' env') mtipe
162310
163− -- TODO: Raw -> Canonical
164− Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)
311+ Var (Var.Raw x) -> Var <$> format (variable env x)
165312
166− Data name es -> Data name <$> mapM rnm es
313+ Data name es -> Data name <$> mapM go es
167314
168− ExplicitList es -> ExplicitList <$> mapM rnm es
315+ ExplicitList es -> ExplicitList <$> mapM go es
169316
170− Case e cases -> Case <$> rnm e <*> mapM branch cases
317+ Case e cases -> Case <$> go e <*> mapM branch cases
171318 where
172− branch (pattern,b) = (,) <$> format (renamePattern env pattern)
173− <*> rename (extend env pattern) b
319+ branch (p,b) = (,) <$> format (pattern env p)
320+ <*> expression (update p env) b
174321
175− Markdown uid md es -> Markdown uid md <$> mapM rnm es
322+ Markdown uid md es -> Markdown uid md <$> mapM go es
176323
177− PortIn name st -> PortIn name <$> renameType' env st
324+ PortIn name st -> PortIn name <$> tipe' env st
178325
179− PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
326+ PortOut name st signal -> PortOut name <$> tipe' env st <*> go signal
180327
181328
182−renamePattern :: Env -> P.Pattern -> Either String P.Pattern
183−renamePattern env pattern =
184− case pattern of
185− P.Var _ -> return pattern
186− P.Literal _ -> return pattern
187− P.Record _ -> return pattern
188− P.Anything -> return pattern
189− P.Alias x p -> P.Alias x <$> renamePattern env p
190− P.Data name ps -> P.Data <$> replace "pattern" env name
191− <*> mapM (renamePattern env) ps
329+pattern :: Environment -> P.RawPattern -> Either String P.CanonicalPattern
330+pattern env ptrn =
331+ case ptrn of
332+ P.Var x -> return $ P.Var x
333+ P.Literal lit -> return $ P.Literal lit
334+ P.Record fs -> return $ P.Record fs
335+ P.Anything -> return P.Anything
336+ P.Alias x p -> P.Alias x <$> pattern env p
337+ P.Data (Var.Raw name) ps ->
338+ P.Data <$> pvar env name
339+ <*> mapM (pattern env) ps