git.iko.soy/elk
on master help sign in
Starting to get Canonicalize working with new AST
ee5e0fbEvan Czaplicki
compiler/Transform/Canonicalize.hs+300−152
compare with master
unifiedsplit
@@ -1,191 +1,339 @@
1−{-# OPTIONS_GHC -Wall #-}
1+{-# OPTIONS_GHC -W #-}
2−module Transform.Canonicalize (interface, metadataModule) where
2+module Transform.Canonicalize {-(interface, metadataModule)-} where
3
3
4−import Control.Arrow ((***))
4+import Control.Applicative ((<$>),(<*>))
5−import Control.Applicative (Applicative,(<$>),(<*>))
6−import Control.Monad.Identity
5+import Control.Arrow (first)
6+import Control.Monad (foldM)
7import qualified Data.Either as Either
7import qualified Data.Either as Either
8import qualified Data.List as List
8import qualified Data.List as List
9+import Data.Map ((!))
9import qualified Data.Map as Map
10import qualified Data.Map as Map
10−import qualified Data.Set as Set
11import qualified Data.Traversable as T
11import qualified Data.Traversable as T
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
12−import SourceSyntax.Annotation as A
21+import qualified AST.Annotation as A
13−import SourceSyntax.Expression
22+import AST.Declaration as D
14−import SourceSyntax.Module
15−import SourceSyntax.PrettyPrint (pretty)
23+import AST.PrettyPrint (pretty, commaSep)
16−import qualified SourceSyntax.Pattern as P
24+import qualified AST.Pattern as P
17−import qualified SourceSyntax.Type as Type
18−import qualified SourceSyntax.Variable as Var
19import Text.PrettyPrint as P
25import Text.PrettyPrint as P
20
26
21−interface :: String -> ModuleInterface -> ModuleInterface
27+import Transform.Canonicalize.Environment
22−interface moduleName iface =
28+import Transform.Canonicalize.Type
23− ModuleInterface
29+import Transform.Canonicalize.Variable (variable, pvar)
24− { iVersion = iVersion iface
30+import qualified Transform.SortDefinitions as Transform
25− , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))
31+import qualified Transform.Declaration as Transform
26− , iImports = iImports iface
32+
27− , iAdts = map (both prefix renameCtors) (iAdts iface)
33+environment :: Interfaces -> Module.ValidModule -> Either [Doc] Environment
28− , iAliases = map (both prefix renameType') (iAliases iface)
34+environment interfaces (Module.Module _ _ _ ims decls) =
29− , iFixities = iFixities iface -- cannot have canonicalized operators while parsing
35+ do () <- allImportsAvailable interfaces ims
30− , iPorts = iPorts iface
36+ nonLocalEnv <- foldM (toEnv interfaces) builtIns ims
31− }
37+ foldM (flip addDecl) nonLocalEnv decls
32− where
38+
33− both f g (a,b,c) = (f a, b, g c)
39+toEnv :: Interfaces -> Environment -> (String, ImportMethod) -> Either [Doc] Environment
34− prefix name = moduleName ++ "." ++ name
40+toEnv interfaces environ (name,method) =
35−
41+ case method of
36− pair name = (name, moduleName ++ "." ++ name)
42+ Module.As name' ->
37− canon (name,_,_) = pair name
43+ return (env (name' ++ "."))
38− canons = Map.fromList $ concat
44+
39− [ map canon (iAdts iface), map canon (iAliases iface) ]
45+ Module.Open (Var.Listing vs open)
40−
46+ | open -> return (env "")
41− renameCtors ctors =
47+ | otherwise -> foldM (addValue name interface) environ vs
42− map (prefix *** map renameType') ctors
48+ where
43− renameType' =
49+ interface = interfaces ! name
44− runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
50+
45−
51+ env prefix =
46−renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type
52+ let dict' = dict . map (first (prefix++)) in
47−renameType renamer tipe =
53+ Env { _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
48− let rnm = renameType renamer in
54+ , _adts = dict' $ map pair (Map.keys (iAdts interface))
49− case tipe of
55+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))
50− Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
56+ , _patterns = dict' $ ctors
51− Type.Var _ -> return tipe
57+ }
52− Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
58+
53− Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext
59+ canonical :: String -> Var.Canonical
54− where rnm' (f,t) = (,) f <$> rnm t
60+ canonical = Var.Canonical (Var.Module name)
55−
61+
56−metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
62+ pair :: String -> (String, Var.Canonical)
57−metadataModule ifaces modul =
63+ pair key = (key, canonical key)
58− do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
64+
59− [] -> Right ()
65+ alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
60− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ++
66+
61− "\n You may need to compile with the --make flag to detect modules you have written."
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+ ]
62− ]
138+ ]
63− program' <- rename initialEnv (program modul)
139+
64− aliases' <- mapM (three3 renameType') (aliases modul)
140+ D.Port _ -> return env
65− datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)
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
66− return $ modul { program = program'
149+ return $ modul { exports = exports'
67− , aliases = aliases'
150+ , body = body canonicalDecls
68− , datatypes = datatypes' }
151+ }
69 where
152 where
70− two2 f (a,b) = (,) a <$> f b
153+ locals :: [Var.Value]
71− three3 f (a,b,c) = (,,) a b <$> f c
154+ locals = concatMap declToValue decls
72− renameType' =
155+
73− Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
156+ body :: [D.CanonicalDecl] -> CanonicalBody
74−
157+ body decls =
75− get1 (a,_,_) = a
158+ CanonicalBody
76− canon (name, importMethod) =
159+ { program = Transform.sortDefs . dummyLet $ Transform.toExpr decls
77− let pair pre var = (pre ++ drop (length name + 1) var, var)
160+ , types = Map.empty
78− iface = ifaces Map.! name
161+ , datatypes = Map.fromList [ (name,(vars,ctors)) | Datatype name vars ctors <- decls ]
79− allNames = concat [ Map.keys (iTypes iface)
162+ , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]
80− , map get1 (iAliases iface)
163+ , aliases = Map.fromList [ (name,(tvs,alias)) | TypeAlias name tvs alias <- decls ]
81− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]
164+ , ports = [ portName port | Port port <- decls ]
82− in case importMethod of
165+ }
83− As alias -> map (pair (alias ++ ".")) allNames
166+
84− Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames
167+delist :: [Var.Value] -> Var.Listing Var.Value -> Either [Doc] [Var.Value]
85− where vs = Set.fromList vars
168+delist fullList (Var.Listing partial open)
86− Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
169+ | open = return fullList
87− where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
170+ | otherwise = go [] (List.sort fullList) (List.sort partial)
88−
171+ where
89− two n = (n,n)
172+ notFound xs =
90− localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))
173+ Left $ [ P.text "Export Error: trying to export non-existent values:" <+>
91− globalEnv =
174+ commaSep (map pretty xs)
92− map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++
175+ ]
93− map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]
176+
94− realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
177+ go list full partial =
95− initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
178+ case (full, partial) of
96−
179+ (_, []) -> return list
97−type Env = Map.Map String String
180+ ([], _) -> notFound partial
98−
181+ (x:xs, y:ys) ->
99−extend :: Env -> P.Pattern -> Env
182+ case (x,y) of
100−extend env pattern = Map.union (Map.fromList (zip xs xs)) env
183+ (Var.Value x', Var.Value y') | x' == y' ->
101− where xs = P.boundVarList pattern
184+ go (x : list) xs ys
102−
185+
103−replace :: String -> Env -> String -> Either String String
186+ (Var.Alias x', Var.Alias y') | x' == y' ->
104−replace variable env v =
187+ go (x : list) xs ys
105− if List.isPrefixOf "Native." v then return v else
188+
106− case Map.lookup v env of
189+ (Var.ADT x' (Var.Listing xctors _ ),
107− Just v' -> return v'
190+ Var.ADT y' (Var.Listing yctors open)) | x' == y' ->
108− Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg
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
109 where
230 where
110− matches = filter (List.isInfixOf v) (Map.keys env)
231+ canonicalize' (ctor,args) =
111− msg = if null matches then "" else
232+ (,) ctor <$> mapM (canonicalize tipe "datatype" name env) args
112− "\nClose matches include: " ++ List.intercalate ", " matches
233+
113−
234+ D.TypeAlias name tvars expanded ->
114−-- TODO: Var.Raw -> Var.Canonical
235+ D.TypeAlias name tvars <$> canonicalize tipe "type alias" name env expanded
115−rename :: Env -> Expr -> Either [Doc] Expr
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
116−rename env (A ann expr) =
263+expression env (A.A ann expr) =
117− let rnm = rename env
264+ let go = expression env
265+ tipe' environ = format . tipe environ
118 throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon
266 throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon
119 , P.text err
267 , P.text err
120 ]
268 ]
121 ]
269 ]
122 format = Either.either throw return
270 format = Either.either throw return
123− renameType' environ = renameType (format . replace "variable" environ)
124 in
271 in
125− A ann <$>
272+ A.A ann <$>
126 case expr of
273 case expr of
127− Literal _ -> return expr
274+ Literal lit -> return (Literal lit)
128
275
129− Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
276+ Range e1 e2 -> Range <$> go e1 <*> go e2
130
277
131− Access e x -> Access <$> rnm e <*> return x
278+ Access e x -> Access <$> go e <*> return x
132
279
133− Remove e x -> flip Remove x <$> rnm e
280+ Remove e x -> flip Remove x <$> go e
134
281
135− Insert e x v -> flip Insert x <$> rnm e <*> rnm v
282+ Insert e x v -> flip Insert x <$> go e <*> go v
136
283
137 Modify e fs ->
284 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
139
286
140− Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs
287+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fs
141
288
142− Binop op e1 e2 ->
289+ Binop (Var.Raw op) e1 e2 ->
143− do op' <- format (replace "variable" env op)
290+ do op' <- format (variable env op)
144− Binop op' <$> rnm e1 <*> rnm e2
291+ Binop op' <$> go e1 <*> go e2
145
292
146− Lambda pattern e ->
293+ Lambda p e ->
147− let env' = extend env pattern in
294+ let env' = update p env in
148− Lambda <$> format (renamePattern env' pattern) <*> rename env' e
295+ Lambda <$> format (pattern env' p) <*> expression env' e
149
296
150− App e1 e2 -> App <$> rnm e1 <*> rnm e2
297+ App e1 e2 -> App <$> go e1 <*> go e2
151
298
152− MultiIf ps -> MultiIf <$> mapM grnm ps
299+ MultiIf ps -> MultiIf <$> mapM go' ps
153− where grnm (b,e) = (,) <$> rnm b <*> rnm e
300+ where go' (b,e) = (,) <$> go b <*> go e
154
301
155− Let defs e -> Let <$> mapM rename' defs <*> rename env' e
302+ Let defs e -> Let <$> mapM rename' defs <*> expression env' e
156 where
303 where
157− env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
304+ env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs
158− rename' (Definition p body mtipe) =
305+ rename' (Valid.Definition p body mtipe) =
306+ Canonical.Definition
159− Definition <$> format (renamePattern env' p)
307+ <$> format (pattern env' p)
160− <*> rename env' body
308+ <*> expression env' body
161− <*> T.traverse (renameType' env') mtipe
309+ <*> T.traverse (tipe' env') mtipe
162
310
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)
165
312
166− Data name es -> Data name <$> mapM rnm es
313+ Data name es -> Data name <$> mapM go es
167
314
168− ExplicitList es -> ExplicitList <$> mapM rnm es
315+ ExplicitList es -> ExplicitList <$> mapM go es
169
316
170− Case e cases -> Case <$> rnm e <*> mapM branch cases
317+ Case e cases -> Case <$> go e <*> mapM branch cases
171 where
318 where
172− branch (pattern,b) = (,) <$> format (renamePattern env pattern)
319+ branch (p,b) = (,) <$> format (pattern env p)
173− <*> rename (extend env pattern) b
320+ <*> expression (update p env) b
174
321
175− Markdown uid md es -> Markdown uid md <$> mapM rnm es
322+ Markdown uid md es -> Markdown uid md <$> mapM go es
176
323
177− PortIn name st -> PortIn name <$> renameType' env st
324+ PortIn name st -> PortIn name <$> tipe' env st
178
325
179− PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
326+ PortOut name st signal -> PortOut name <$> tipe' env st <*> go signal
180
327
181
328
182−renamePattern :: Env -> P.Pattern -> Either String P.Pattern
329+pattern :: Environment -> P.RawPattern -> Either String P.CanonicalPattern
183−renamePattern env pattern =
330+pattern env ptrn =
184− case pattern of
331+ case ptrn of
185− P.Var _ -> return pattern
332+ P.Var x -> return $ P.Var x
186− P.Literal _ -> return pattern
333+ P.Literal lit -> return $ P.Literal lit
187− P.Record _ -> return pattern
334+ P.Record fs -> return $ P.Record fs
188− P.Anything -> return pattern
335+ P.Anything -> return P.Anything
189− P.Alias x p -> P.Alias x <$> renamePattern env p
336+ P.Alias x p -> P.Alias x <$> pattern env p
337+ P.Data (Var.Raw name) ps ->
190− P.Data name ps -> P.Data <$> replace "pattern" env name
338+ P.Data <$> pvar env name
191− <*> mapM (renamePattern env) ps
339+ <*> mapM (pattern env) ps
compiler/Transform/Canonicalize/Environment.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.Canonicalize.Environment where
3+
4+import Control.Arrow (second)
5+import qualified Data.Map as Map
6+
7+import AST.Expression.General (saveEnvName)
8+import qualified AST.Pattern as P
9+import qualified AST.Type as Type
10+import qualified AST.Variable as Var
11+
12+type Dict a = Map.Map String [a]
13+
14+dict :: [(String,a)] -> Dict a
15+dict pairs = Map.fromList $ map (second (:[])) pairs
16+
17+insert :: String -> a -> Dict a -> Dict a
18+insert key value = Map.insertWith (++) key [value]
19+
20+data Environment = Env
21+ { _values :: Dict Var.Canonical
22+ , _adts :: Dict Var.Canonical
23+ , _aliases :: Dict (Var.Canonical, [String], Type.CanonicalType)
24+ , _patterns :: Dict Var.Canonical
25+ }
26+
27+builtIns :: Environment
28+builtIns =
29+ Env { _values = builtIn ([saveEnvName,"::","[]"] ++ tuples)
30+ , _adts = builtIn ["_List","Int","Float","Char","Bool","String"]
31+ , _aliases = dict []
32+ , _patterns = builtIn (["::","[]"] ++ tuples)
33+ }
34+ where
35+ builtIn xs = dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs
36+ tuples = map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]
37+
38+update :: P.Pattern var -> Environment -> Environment
39+update ptrn env =
40+ env { _values = foldr put (_values env) (P.boundVarList ptrn) }
41+ where
42+ put x = Map.insert x [Var.local x]
43+
44+merge :: Environment -> Environment -> Environment
45+merge (Env v1 t1 a1 p1) (Env v2 t2 a2 p2) =
46+ Env { _values = Map.unionWith (++) v1 v2
47+ , _adts = Map.unionWith (++) t1 t2
48+ , _aliases = Map.unionWith (++) a1 a2
49+ , _patterns = Map.unionWith (++) p1 p2
50+ }
compiler/Transform/Canonicalize/Type.hsnew file+71
@@ -0,0 +1,71 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.Canonicalize.Type where
3+
4+import Control.Arrow (second)
5+import Control.Applicative ((<$>),(<*>))
6+import qualified Data.Map as Map
7+import Data.Traversable (traverse)
8+
9+import qualified AST.Type as T
10+import qualified AST.Variable as Var
11+
12+import Transform.Canonicalize.Environment
13+import Transform.Canonicalize.Variable (tvar)
14+
15+tipe :: Environment -> T.RawType -> Either String T.CanonicalType
16+tipe env typ =
17+ let go = tipe env in
18+ case typ of
19+ T.Lambda a b ->
20+ T.Lambda <$> go a <*> go b
21+
22+ T.Var x ->
23+ return (T.Var x)
24+
25+ T.Record fields ext ->
26+ T.Record <$> mapM go' fields <*> traverse go ext
27+ where
28+ go' (f,t) = (,) f <$> go t
29+
30+ T.Aliased name t ->
31+ T.Aliased name <$> go t
32+
33+ T.Data (Var.Raw name) ts ->
34+ case tvar env name of
35+ Left err -> Left err
36+
37+ Right (Left name') ->
38+ T.Data name' <$> mapM go ts
39+
40+ Right (Right (name', tvars, t))
41+ | tsLen /= tvarsLen -> Left msg
42+ | otherwise ->
43+ do ts' <- mapM go ts
44+ let t' = replace (Map.fromList (zip tvars ts')) t
45+ return $ T.Aliased name' t'
46+ where
47+ tsLen = length ts
48+ tvarsLen = length tvars
49+
50+ msg = "Type alias '" ++ name ++ "' expects " ++ show tvarsLen ++
51+ " type argument" ++ (if tvarsLen == 1 then "" else "s") ++
52+ " but was given " ++ show tsLen
53+
54+replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType
55+replace typeTable t =
56+ let go = replace typeTable in
57+ case t of
58+ T.Lambda a b ->
59+ T.Lambda (go a) (go b)
60+
61+ T.Var x ->
62+ Map.findWithDefault t x typeTable
63+
64+ T.Record fields ext ->
65+ T.Record (map (second go) fields) (fmap go ext)
66+
67+ T.Aliased original t' ->
68+ T.Aliased original (go t')
69+
70+ T.Data name ts ->
71+ T.Data name (map go ts)
compiler/Transform/Canonicalize/Variable.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# OPTIONS_GHC -W #-}
2+module Transform.Canonicalize.Variable where
3+
4+import qualified Data.List as List
5+import qualified Data.Map as Map
6+import Data.Maybe (fromMaybe)
7+
8+import AST.Helpers as Help
9+import qualified AST.Type as Type
10+import qualified AST.Variable as Var
11+import Transform.Canonicalize.Environment
12+
13+variable :: Environment -> String -> Either String Var.Canonical
14+variable env var =
15+ case modul of
16+ Just ms@(m:_)
17+ | m == "Native" -> return (Var.Canonical home name)
18+ where
19+ home = Var.Module (List.intercalate "." ms)
20+
21+ _ -> case Map.lookup var (_values env) of
22+ Just [v] -> return v
23+ Just vs -> Left (ambiguous "variable" (map Var.toString vs) var)
24+ Nothing -> Left (notFound "variable" (Map.keys (_values env)) var)
25+ where
26+ (modul, name) = case Help.splitDots var of
27+ [x] -> (Nothing, x)
28+ xs -> (Just (init xs), last xs)
29+
30+tvar :: Environment -> String
31+ -> Either String (Either Var.Canonical (Var.Canonical, [String], Type.Type Var.Canonical))
32+tvar env var =
33+ case adts ++ aliases of
34+ [] -> Left $ notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var
35+ [v] -> return v
36+ vs -> Left $ ambiguous "type" (map toString vs) var
37+ where
38+ adts = map Left . fromMaybe [] $ Map.lookup var (_adts env)
39+ aliases = map Right . fromMaybe [] $ Map.lookup var (_aliases env)
40+ toString v =
41+ Var.toString $ case v of
42+ Left x -> x
43+ Right (x,_,_) -> x
44+
45+pvar :: Environment -> String -> Either String Var.Canonical
46+pvar env var =
47+ case Map.lookup var (_patterns env) of
48+ Just [v] -> return v
49+ Just vs -> Left (ambiguous "pattern" (map Var.toString vs) var)
50+ Nothing -> Left (notFound "pattern" (Map.keys (_patterns env)) var)
51+
52+notFound :: String -> [String] -> String -> String
53+notFound kind possibilities var =
54+ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ msg
55+ where
56+ matches = filter (List.isInfixOf var) possibilities
57+ msg = if null matches then "" else
58+ "\nClose matches include: " ++ List.intercalate ", " matches
59+
60+ambiguous :: String -> [String] -> String -> String
61+ambiguous kind possibilities var =
62+ "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++
63+ " Disambiguate between: " ++ List.intercalate ", " possibilities
64+
compiler/Transform/Check.hs+21−17
@@ -6,17 +6,18 @@ import qualified Data.List as List
6import qualified Data.Maybe as Maybe
6import qualified Data.Maybe as Maybe
7import qualified Data.Set as Set
7import qualified Data.Set as Set
8
8
9−import qualified SourceSyntax.Expression as E
9+import qualified AST.Expression.Valid as Valid
10−import qualified SourceSyntax.Declaration as D
10+import qualified AST.Declaration as D
11−import qualified SourceSyntax.Pattern as Pattern
11+import qualified AST.Pattern as Pattern
12−import qualified SourceSyntax.Type as T
12+import qualified AST.Type as T
13+import qualified AST.Variable as Var
13import qualified Transform.Expression as Expr
14import qualified Transform.Expression as Expr
14
15
15−import SourceSyntax.PrettyPrint
16+import AST.PrettyPrint
16import Text.PrettyPrint as P
17import Text.PrettyPrint as P
17
18
18
19
19−mistakes :: [D.Declaration] -> [Doc]
20+mistakes :: [D.ValidDecl] -> [Doc]
20mistakes decls =
21mistakes decls =
21 concat [ infiniteTypeAliases decls
22 concat [ infiniteTypeAliases decls
22 , illFormedTypes decls
23 , illFormedTypes decls
@@ -30,7 +31,7 @@ dupErr :: String -> String -> String
30dupErr err x =
31dupErr err x =
31 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
32 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
32
33
33−duplicates :: [D.Declaration] -> [String]
34+duplicates :: [D.ValidDecl] -> [String]
34duplicates decls =
35duplicates decls =
35 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
36 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
36 case mapM exprDups (portExprs ++ defExprs) of
37 case mapM exprDups (portExprs ++ defExprs) of
@@ -41,7 +42,7 @@ duplicates decls =
41 msg = dupErr "definition of"
42 msg = dupErr "definition of"
42
43
43 (defPatterns, defExprs) =
44 (defPatterns, defExprs) =
44− unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
45+ unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]
45
46
46 (portNames, portExprs) =
47 (portNames, portExprs) =
47 Arrow.second concat $ unzip $
48 Arrow.second concat $ unzip $
@@ -50,17 +51,17 @@ duplicates decls =
50 D.Out name expr _ -> (name, [expr])
51 D.Out name expr _ -> (name, [expr])
51 D.In name _ -> (name, [])
52 D.In name _ -> (name, [])
52
53
53− exprDups :: E.Expr -> Either String E.Expr
54+ exprDups :: Valid.Expr -> Either String Valid.Expr
54 exprDups expr = Expr.crawlLet defsDups expr
55 exprDups expr = Expr.crawlLet defsDups expr
55
56
56− defsDups :: [E.Def] -> Either String [E.Def]
57+ defsDups :: [Valid.Def] -> Either String [Valid.Def]
57 defsDups defs =
58 defsDups defs =
58− let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in
59+ let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in
59 case dups $ concatMap varsIn defs of
60 case dups $ concatMap varsIn defs of
60 [] -> Right defs
61 [] -> Right defs
61 name:_ -> Left name
62 name:_ -> Left name
62
63
63−duplicateConstructors :: [D.Declaration] -> [String]
64+duplicateConstructors :: [D.ValidDecl] -> [String]
64duplicateConstructors decls =
65duplicateConstructors decls =
65 map (dupErr "definition of type constructor") (dups typeCtors) ++
66 map (dupErr "definition of type constructor") (dups typeCtors) ++
66 map (dupErr "definition of data constructor") (dups dataCtors)
67 map (dupErr "definition of data constructor") (dups dataCtors)
@@ -68,7 +69,7 @@ duplicateConstructors decls =
68 typeCtors = [ name | D.Datatype name _ _ <- decls ]
69 typeCtors = [ name | D.Datatype name _ _ <- decls ]
69 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
70 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
70
71
71−illFormedTypes :: [D.Declaration] -> [Doc]
72+illFormedTypes :: [D.ValidDecl] -> [Doc]
72illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
73illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
73 where
74 where
74 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
75 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
@@ -80,7 +81,8 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
80 T.Var x -> Set.singleton x
81 T.Var x -> Set.singleton x
81 T.Data _ ts -> Set.unions (map freeVars ts)
82 T.Data _ ts -> Set.unions (map freeVars ts)
82 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
83 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
83− where ext' = maybe Set.empty Set.singleton ext
84+ where ext' = maybe Set.empty freeVars ext
85+ T.Aliased _ t -> freeVars t
84
86
85 undeclared tvars tipes = Set.difference used declared
87 undeclared tvars tipes = Set.difference used declared
86 where
88 where
@@ -113,20 +115,22 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
113 quote tvar = "'" ++ tvar ++ "'"
115 quote tvar = "'" ++ tvar ++ "'"
114
116
115
117
116−infiniteTypeAliases :: [D.Declaration] -> [Doc]
118+infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
117infiniteTypeAliases decls =
119infiniteTypeAliases decls =
118 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
120 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
119 , infiniteType name tipe ]
121 , infiniteType name tipe ]
120 where
122 where
123+ infiniteType :: String -> T.Type Var.Raw -> Bool
121 infiniteType name tipe =
124 infiniteType name tipe =
122 let infinite = infiniteType name in
125 let infinite = infiniteType name in
123 case tipe of
126 case tipe of
124 T.Lambda a b -> infinite a || infinite b
127 T.Lambda a b -> infinite a || infinite b
125 T.Var _ -> False
128 T.Var _ -> False
126− T.Data name' ts -> name == name' || any infinite ts
129+ T.Data (Var.Raw name') ts -> name == name' || any infinite ts
127 T.Record fields _ -> any (infinite . snd) fields
130 T.Record fields _ -> any (infinite . snd) fields
131+ T.Aliased _ t -> infinite t
128
132
129− indented :: D.Declaration -> Doc
133+ indented :: D.ValidDecl -> Doc
130 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
134 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
131
135
132 report name args tipe =
136 report name args tipe =
compiler/Transform/Declaration.hs+86−24
@@ -1,16 +1,23 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Transform.Declaration where
2+module Transform.Declaration (combineAnnotations, toExpr) where
3
3
4import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
5+
5−import qualified SourceSyntax.Pattern as P
6+import qualified AST.Annotation as A
6−import SourceSyntax.Expression as E
7−import SourceSyntax.Declaration as D
7+import qualified AST.Declaration as D
8+import qualified AST.Expression.General as E
9+import qualified AST.Expression.Source as Source
10+import qualified AST.Expression.Valid as Valid
11+import qualified AST.Expression.Canonical as Canonical
12+import qualified AST.Pattern as P
13+import qualified AST.Type as T
14+import qualified AST.Variable as Var
8
15
9import qualified Transform.Expression as Expr
16import qualified Transform.Expression as Expr
10import qualified Transform.Definition as Def
17import qualified Transform.Definition as Def
11
18
12
19
13−combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]
20+combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]
14combineAnnotations = go
21combineAnnotations = go
15 where
22 where
16 msg x = "Syntax Error: The type annotation for '" ++ x ++
23 msg x = "Syntax Error: The type annotation for '" ++ x ++
@@ -23,41 +30,96 @@ combineAnnotations = go
23 -- simple cases, pass them through with no changes
30 -- simple cases, pass them through with no changes
24 [] -> return []
31 [] -> return []
25
32
26− Datatype name tvars ctors : rest ->
33+ D.Datatype name tvars ctors : rest ->
27− (:) (Datatype name tvars ctors) <$> go rest
34+ (:) (D.Datatype name tvars ctors) <$> go rest
28
35
29− TypeAlias name tvars alias : rest ->
36+ D.TypeAlias name tvars alias : rest ->
30− (:) (TypeAlias name tvars alias) <$> go rest
37+ (:) (D.TypeAlias name tvars alias) <$> go rest
31
38
32− Fixity assoc prec op : rest ->
39+ D.Fixity assoc prec op : rest ->
33− (:) (Fixity assoc prec op) <$> go rest
40+ (:) (D.Fixity assoc prec op) <$> go rest
34
41
35 -- combine definitions
42 -- combine definitions
36 D.Definition def : defRest ->
43 D.Definition def : defRest ->
37 case def of
44 case def of
38− Def pat expr ->
45+ Source.Definition pat expr ->
39 do expr' <- exprCombineAnnotations expr
46 do expr' <- exprCombineAnnotations expr
40− let def' = E.Definition pat expr' Nothing
47+ let def' = Valid.Definition pat expr' Nothing
41 (:) (D.Definition def') <$> go defRest
48 (:) (D.Definition def') <$> go defRest
42
49
43− TypeAnnotation name tipe ->
50+ Source.TypeAnnotation name tipe ->
44 case defRest of
51 case defRest of
45− D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->
52+ D.Definition (Source.Definition pat@(P.Var name') expr) : rest
53+ | name == name' ->
46− do expr' <- exprCombineAnnotations expr
54+ do expr' <- exprCombineAnnotations expr
47− let def' = E.Definition pat expr' (Just tipe)
55+ let def' = Valid.Definition pat expr' (Just tipe)
48− (:) (D.Definition def') <$> go rest
56+ (:) (D.Definition def') <$> go rest
49
57
50 _ -> Left (msg name)
58 _ -> Left (msg name)
51
59
52 -- combine ports
60 -- combine ports
53− Port port : portRest ->
61+ D.Port port : portRest ->
54 case port of
62 case port of
55− PPDef name _ -> Left (msg name)
63+ D.PPDef name _ -> Left (msg name)
56− PPAnnotation name tipe ->
64+ D.PPAnnotation name tipe ->
57 case portRest of
65 case portRest of
58− Port (PPDef name' expr) : rest | name == name' ->
66+ D.Port (D.PPDef name' expr) : rest | name == name' ->
59 do expr' <- exprCombineAnnotations expr
67 do expr' <- exprCombineAnnotations expr
60− (:) (Port (Out name expr' tipe)) <$> go rest
68+ (:) (D.Port (D.Out name expr' tipe)) <$> go rest
69+
70+ _ -> (:) (D.Port (D.In name tipe)) <$> go portRest
71+
72+
73+toExpr :: [D.CanonicalDecl] -> [Canonical.Def]
74+toExpr = concatMap toDefs
75+
76+toDefs :: D.CanonicalDecl -> [Canonical.Def]
77+toDefs decl =
78+ case decl of
79+ D.Definition def -> [def]
80+
81+ D.Datatype name tvars constructors -> concatMap toDefs' constructors
82+ where
83+ toDefs' (ctor, tipes) =
84+ let vars = take (length tipes) arguments
85+ tbody = T.Data (Var.local name) $ map T.Var tvars
86+ body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
87+ in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
88+
89+ D.TypeAlias name _ tipe@(T.Record fields ext) ->
90+ [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
91+ where
92+ args = map snd fields ++ maybe [] (:[]) ext
93+
94+ var = A.none . E.localVar
95+ vars = take (length args) arguments
96+
97+ efields = zip (map fst fields) (map var vars)
98+ record = case ext of
99+ Nothing -> A.none $ E.Record efields
100+ Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
101+
102+ -- Type aliases must be added to an extended equality dictionary,
103+ -- but they do not require any basic constraints.
104+ D.TypeAlias _ _ _ -> []
105+
106+ D.Port port ->
107+ case port of
108+ D.Out name expr@(A.A s _) tipe ->
109+ [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
110+ D.In name tipe ->
111+ [ definition name (A.none $ E.PortIn name tipe) tipe ]
112+
113+ -- no constraints are needed for fixity declarations
114+ D.Fixity _ _ _ -> []
115+
116+
117+arguments :: [String]
118+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
61
119
62− _ -> (:) (Port (In name tipe)) <$> go portRest
120+buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
121+buildFunction body@(A.A s _) vars =
122+ foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
63
123
124+definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
125+definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe)
compiler/Transform/Definition.hs+14−10
@@ -2,11 +2,12 @@
2module Transform.Definition where
2module Transform.Definition where
3
3
4import Control.Applicative ((<$>))
4import Control.Applicative ((<$>))
5−import qualified SourceSyntax.Pattern as P
5+import qualified AST.Pattern as P
6−import SourceSyntax.Expression
6+import qualified AST.Expression.Source as Source
7+import qualified AST.Expression.Valid as Valid
7import qualified Transform.Expression as Expr
8import qualified Transform.Expression as Expr
8
9
9−combineAnnotations :: [ParseDef] -> Either String [Def]
10+combineAnnotations :: [Source.Def] -> Either String [Valid.Def]
10combineAnnotations = go
11combineAnnotations = go
11 where
12 where
12 msg x = "Syntax Error: The type annotation for '" ++ x ++
13 msg x = "Syntax Error: The type annotation for '" ++ x ++
@@ -16,16 +17,19 @@ combineAnnotations = go
16
17
17 go defs =
18 go defs =
18 case defs of
19 case defs of
19− TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->
20+ Source.TypeAnnotation name tipe : rest ->
21+ case rest of
22+ Source.Definition pat@(P.Var name') expr : rest'
23+ | name == name' ->
20− do expr' <- exprCombineAnnotations expr
24+ do expr' <- exprCombineAnnotations expr
21− let def = Definition pat expr' (Just tipe)
25+ let def = Valid.Definition pat expr' (Just tipe)
22− (:) def <$> go rest
26+ (:) def <$> go rest'
23
27
24− TypeAnnotation name _ : _ -> Left (msg name)
28+ _ -> Left (msg name)
25
29
26− Def pat expr : rest ->
30+ Source.Definition pat expr : rest ->
27 do expr' <- exprCombineAnnotations expr
31 do expr' <- exprCombineAnnotations expr
28− let def = Definition pat expr' Nothing
32+ let def = Valid.Definition pat expr' Nothing
29 (:) def <$> go rest
33 (:) def <$> go rest
30
34
31 [] -> return []
35 [] -> return []
compiler/Transform/Expression.hs+15−14
@@ -2,31 +2,32 @@
2module Transform.Expression (crawlLet, checkPorts) where
2module Transform.Expression (crawlLet, checkPorts) where
3
3
4import Control.Applicative ((<$>),(<*>))
4import Control.Applicative ((<$>),(<*>))
5−import SourceSyntax.Annotation ( Annotated(A) )
5+import AST.Annotation ( Annotated(A) )
6−import SourceSyntax.Expression
6+import AST.Expression.General
7−import SourceSyntax.Type (Type)
7+import qualified AST.Expression.Canonical as Canonical
8+import AST.Type (Type, CanonicalType)
8
9
9crawlLet :: ([def] -> Either a [def'])
10crawlLet :: ([def] -> Either a [def'])
10− -> GeneralExpr ann def var
11+ -> Expr ann def var
11− -> Either a (GeneralExpr ann def' var)
12+ -> Either a (Expr ann def' var)
12crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
13crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
13
14
14−checkPorts :: (String -> Type -> Either a ())
15+checkPorts :: (String -> CanonicalType -> Either a ())
15− -> (String -> Type -> Either a ())
16+ -> (String -> CanonicalType -> Either a ())
16− -> Expr
17+ -> Canonical.Expr
17− -> Either a Expr
18+ -> Either a Canonical.Expr
18checkPorts inCheck outCheck expr =
19checkPorts inCheck outCheck expr =
19 crawl inCheck outCheck (mapM checkDef) expr
20 crawl inCheck outCheck (mapM checkDef) expr
20 where
21 where
21− checkDef def@(Definition _ body _) =
22+ checkDef def@(Canonical.Definition _ body _) =
22 do _ <- checkPorts inCheck outCheck body
23 do _ <- checkPorts inCheck outCheck body
23 return def
24 return def
24
25
25−crawl :: (String -> Type -> Either a ())
26+crawl :: (String -> Type var -> Either a ())
26− -> (String -> Type -> Either a ())
27+ -> (String -> Type var -> Either a ())
27 -> ([def] -> Either a [def'])
28 -> ([def] -> Either a [def'])
28− -> GeneralExpr ann def var
29+ -> Expr ann def var
29− -> Either a (GeneralExpr ann def' var)
30+ -> Either a (Expr ann def' var)
30crawl portInCheck portOutCheck defsTransform = go
31crawl portInCheck portOutCheck defsTransform = go
31 where
32 where
32 go (A srcSpan expr) =
33 go (A srcSpan expr) =
compiler/Transform/SortDefinitions.hs+37−21
@@ -7,42 +7,57 @@ import qualified Data.Graph as Graph
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
8import qualified Data.Maybe as Maybe
9import qualified Data.Set as Set
9import qualified Data.Set as Set
10−import SourceSyntax.Annotation
11−import SourceSyntax.Expression
12−import qualified SourceSyntax.Pattern as P
13−import qualified SourceSyntax.Variable as V
14
10
11+import AST.Annotation
12+import AST.Expression.General (Expr'(..))
13+import qualified AST.Expression.Canonical as Canonical
14+import qualified AST.Pattern as P
15+import qualified AST.Variable as V
16+
15−ctors :: P.Pattern -> [String]
17+ctors :: P.CanonicalPattern -> [String]
16ctors pattern =
18ctors pattern =
17 case pattern of
19 case pattern of
18 P.Var _ -> []
20 P.Var _ -> []
19 P.Alias _ p -> ctors p
21 P.Alias _ p -> ctors p
20− P.Data ctor ps -> ctor : concatMap ctors ps
21 P.Record _ -> []
22 P.Record _ -> []
22 P.Anything -> []
23 P.Anything -> []
23 P.Literal _ -> []
24 P.Literal _ -> []
25+ P.Data (V.Canonical home name) ps ->
26+ case home of
27+ V.Local -> name : rest
28+ V.BuiltIn -> rest
29+ V.Module _ -> rest
30+ where
31+ rest = concatMap ctors ps
24
32
25free :: String -> State (Set.Set String) ()
33free :: String -> State (Set.Set String) ()
26free x = modify (Set.insert x)
34free x = modify (Set.insert x)
27
35
36+freeIfLocal :: V.Canonical -> State (Set.Set String) ()
37+freeIfLocal (V.Canonical home name) =
38+ do case home of
39+ V.Local -> free name
40+ V.BuiltIn -> return ()
41+ V.Module _ -> return ()
42+
28bound :: Set.Set String -> State (Set.Set String) ()
43bound :: Set.Set String -> State (Set.Set String) ()
29bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
44bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
30
45
31−sortDefs :: Expr -> Expr
46+sortDefs :: Canonical.Expr -> Canonical.Expr
32sortDefs expr = evalState (reorder expr) Set.empty
47sortDefs expr = evalState (reorder expr) Set.empty
33
48
34−reorder :: Expr -> State (Set.Set String) Expr
49+reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
35reorder (A ann expr) =
50reorder (A ann expr) =
36 A ann <$>
51 A ann <$>
37 case expr of
52 case expr of
38 -- Be careful adding and restricting freeVars
53 -- Be careful adding and restricting freeVars
39− Var (V.Raw x) -> free x >> return expr
54+ Var var -> freeIfLocal var >> return expr
40
55
41 Lambda p e ->
56 Lambda p e ->
42 uncurry Lambda <$> bindingReorder (p,e)
57 uncurry Lambda <$> bindingReorder (p,e)
43
58
44 Binop op e1 e2 ->
59 Binop op e1 e2 ->
45− do free op
60+ do freeIfLocal op
46 Binop op <$> reorder e1 <*> reorder e2
61 Binop op <$> reorder e1 <*> reorder e2
47
62
48 Case e cases ->
63 Case e cases ->
@@ -100,7 +115,7 @@ reorder (A ann expr) =
100 let defss = map Graph.flattenSCC sccs
115 let defss = map Graph.flattenSCC sccs
101
116
102 -- remove let-bound variables from the context
117 -- remove let-bound variables from the context
103− forM_ defs $ \(Definition pattern _ _) -> do
118+ forM_ defs $ \(Canonical.Definition pattern _ _) -> do
104 bound (P.boundVars pattern)
119 bound (P.boundVars pattern)
105 mapM free (ctors pattern)
120 mapM free (ctors pattern)
106
121
@@ -108,7 +123,8 @@ reorder (A ann expr) =
108
123
109 return let'
124 return let'
110
125
126+bindingReorder :: (P.CanonicalPattern, Canonical.Expr)
111−bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)
127+ -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
112bindingReorder (pattern,expr) =
128bindingReorder (pattern,expr) =
113 do expr' <- reorder expr
129 do expr' <- reorder expr
114 bound (P.boundVars pattern)
130 bound (P.boundVars pattern)
@@ -116,8 +132,8 @@ bindingReorder (pattern,expr) =
116 return (pattern, expr')
132 return (pattern, expr')
117
133
118
134
119−reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])
135+reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String])
120−reorderAndGetDependencies (Definition pattern expr mType) =
136+reorderAndGetDependencies (Canonical.Definition pattern expr mType) =
121 do globalFrees <- get
137 do globalFrees <- get
122 -- work in a fresh environment
138 -- work in a fresh environment
123 put Set.empty
139 put Set.empty
@@ -125,28 +141,28 @@ reorderAndGetDependencies (Definition pattern expr mType) =
125 localFrees <- get
141 localFrees <- get
126 -- merge with global frees
142 -- merge with global frees
127 modify (Set.union globalFrees)
143 modify (Set.union globalFrees)
128− return (Definition pattern expr' mType, Set.toList localFrees)
144+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees)
129
145
130
146
131-- This also reorders the all of the sub-expressions in the Def list.
147-- This also reorders the all of the sub-expressions in the Def list.
132−buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]
148+buildDefDict :: [Canonical.Def] -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
133buildDefDict defs =
149buildDefDict defs =
134 do pdefsDeps <- mapM reorderAndGetDependencies defs
150 do pdefsDeps <- mapM reorderAndGetDependencies defs
135 return $ realDeps (addKey pdefsDeps)
151 return $ realDeps (addKey pdefsDeps)
136
152
137 where
153 where
138− addKey :: [(Def, [String])] -> [(Def, Int, [String])]
154+ addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
139 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
155 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
140
156
141− variableToKey :: (Def, Int, [String]) -> [(String, Int)]
157+ variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
142− variableToKey (Definition pattern _ _, key, _) =
158+ variableToKey (Canonical.Definition pattern _ _, key, _) =
143 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
159 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
144
160
145− variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int
161+ variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
146 variableToKeyMap pdefsDeps =
162 variableToKeyMap pdefsDeps =
147 Map.fromList (concatMap variableToKey pdefsDeps)
163 Map.fromList (concatMap variableToKey pdefsDeps)
148
164
149− realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]
165+ realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
150 realDeps pdefsDeps = map convert pdefsDeps
166 realDeps pdefsDeps = map convert pdefsDeps
151 where
167 where
152 varDict = variableToKeyMap pdefsDeps
168 varDict = variableToKeyMap pdefsDeps
compiler/Transform/Substitute.hs+14−8
@@ -4,12 +4,13 @@ module Transform.Substitute (subst) where
4import Control.Arrow (second, (***))
4import Control.Arrow (second, (***))
5import qualified Data.Set as Set
5import qualified Data.Set as Set
6
6
7−import SourceSyntax.Annotation
7+import AST.Annotation
8−import SourceSyntax.Expression
8+import AST.Expression.General (Expr'(..))
9+import qualified AST.Expression.Canonical as Canonical
9−import qualified SourceSyntax.Pattern as Pattern
10+import qualified AST.Pattern as Pattern
10−import qualified SourceSyntax.Variable as V
11+import qualified AST.Variable as V
11
12
12−subst :: String -> Expr' -> Expr' -> Expr'
13+subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'
13subst old new expr =
14subst old new expr =
14 let f (A a e) = A a (subst old new e) in
15 let f (A a e) = A a (subst old new e) in
15 case expr of
16 case expr of
@@ -26,11 +27,16 @@ subst old new expr =
26 | anyShadow -> expr
27 | anyShadow -> expr
27 | otherwise -> Let (map substDef defs) (f body)
28 | otherwise -> Let (map substDef defs) (f body)
28 where
29 where
29− substDef (Definition p e t) = Definition p (f e) t
30+ substDef (Canonical.Definition p e t) = Canonical.Definition p (f e) t
30 anyShadow =
31 anyShadow =
31− any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
32+ any (Set.member old . Pattern.boundVars) [ p | Canonical.Definition p _ _ <- defs ]
33+
34+ Var (V.Canonical home x) ->
35+ case home of
36+ V.Module _ -> expr
37+ V.BuiltIn -> expr
38+ V.Local -> if x == old then new else expr
32
39
33− Var (V.Raw x) -> if x == old then new else expr
34 Case e cases -> Case (f e) $ map (second f) cases
40 Case e cases -> Case (f e) $ map (second f) cases
35 Data name es -> Data name (map f es)
41 Data name es -> Data name (map f es)
36 Access e x -> Access (f e) x
42 Access e x -> Access (f e) x
compiler/Type/Constrain/Declaration.hsdeleted−62
@@ -1,62 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Type.Constrain.Declaration where
3−
4−import qualified SourceSyntax.Annotation as A
5−import qualified SourceSyntax.Declaration as D
6−import qualified SourceSyntax.Expression as E
7−import qualified SourceSyntax.Pattern as P
8−import qualified SourceSyntax.Type as T
9−
10−toExpr :: [D.Declaration] -> [E.Def]
11−toExpr = concatMap toDefs
12−
13−toDefs :: D.Declaration -> [E.Def]
14−toDefs decl =
15− case decl of
16− D.Definition def -> [def]
17−
18− D.Datatype name tvars constructors -> concatMap toDefs' constructors
19− where
20− toDefs' (ctor, tipes) =
21− let vars = take (length tipes) arguments
22− tbody = T.Data name $ map T.Var tvars
23− body = A.none . E.Data ctor $ map (A.none . E.rawVar) vars
24− in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
25−
26− D.TypeAlias name _ tipe@(T.Record fields ext) ->
27− [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
28− where
29− args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
30−
31− var = A.none . E.rawVar
32− vars = take (length args) arguments
33−
34− efields = zip (map fst fields) (map var vars)
35− record = case ext of
36− Nothing -> A.none $ E.Record efields
37− Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
38−
39− -- Type aliases must be added to an extended equality dictionary,
40− -- but they do not require any basic constraints.
41− D.TypeAlias _ _ _ -> []
42−
43− D.Port port ->
44− case port of
45− D.Out name expr@(A.A s _) tipe ->
46− [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
47− D.In name tipe ->
48− [ definition name (A.none $ E.PortIn name tipe) tipe ]
49−
50− -- no constraints are needed for fixity declarations
51− D.Fixity _ _ _ -> []
52−
53−
54−arguments :: [String]
55−arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
56−
57−buildFunction :: E.Expr -> [String] -> E.Expr
58−buildFunction body@(A.A s _) vars =
59− foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
60−
61−definition :: String -> E.Expr -> T.Type -> E.Def
62−definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)