git.iko.soy/elk
on master help sign in
Properly convert Type.Type to SourceSyntax.Type
f8fe8e4Evan Czaplicki
compiler/Compiler.hs+1−6
compare with master
unifiedsplit
@@ -27,7 +27,6 @@ import Paths_Elm
27import SourceSyntax.PrettyPrint (pretty, variable)
27import SourceSyntax.PrettyPrint (pretty, variable)
28import Text.PrettyPrint as P
28import Text.PrettyPrint as P
29import qualified Type.Type as Type
29import qualified Type.Type as Type
30−import qualified Parse.Type as Parse
31import qualified Data.Traversable as Traverse
30import qualified Data.Traversable as Traverse
32
31
33data Flags =
32data Flags =
@@ -125,7 +124,7 @@ buildFile flags moduleNum numModules interfaces filePath =
125 return modul
124 return modul
126
125
127 if print_types flags then printTypes metaModule else return ()
126 if print_types flags then printTypes metaModule else return ()
128− tipes <- toSrcTypes (types metaModule)
127+ tipes <- Traverse.traverse Type.toSrcType (types metaModule)
129 let interface = Canonical.interface name $ ModuleInterface {
128 let interface = Canonical.interface name $ ModuleInterface {
130 iTypes = tipes,
129 iTypes = tipes,
131 iAdts = datatypes metaModule,
130 iAdts = datatypes metaModule,
@@ -136,10 +135,6 @@ buildFile flags moduleNum numModules interfaces filePath =
136 writeFile (elmo flags filePath) (jsModule metaModule)
135 writeFile (elmo flags filePath) (jsModule metaModule)
137 return interface
136 return interface
138
137
139−toSrcTypes tipes = Traverse.traverse convert tipes
140− where
141− convert t = fmap (Parse.readType . P.render) (Type.extraPretty t)
142−
143printTypes metaModule = do
138printTypes metaModule = do
144 putStrLn ""
139 putStrLn ""
145 forM_ (Map.toList $ types metaModule) $ \(n,t) -> do
140 forM_ (Map.toList $ types metaModule) $ \(n,t) -> do
compiler/Type/Type.hs+29
@@ -1,5 +1,6 @@
1module Type.Type where
1module Type.Type where
2
2
3+import qualified Data.Char as Char
3import qualified Data.List as List
4import qualified Data.List as List
4import qualified Data.Map as Map
5import qualified Data.Map as Map
5import qualified Data.UnionFind.IO as UF
6import qualified Data.UnionFind.IO as UF
@@ -336,3 +337,31 @@ instance Crawl Descriptor where
336 structure' <- traverse (crawl nextState) (structure desc)
337 structure' <- traverse (crawl nextState) (structure desc)
337 put state'
338 put state'
338 return $ desc { name = name', structure = structure' }
339 return $ desc { name = name', structure = structure' }
340+
341+
342+toSrcType :: Variable -> IO Src.Type
343+toSrcType variable = do
344+ desc <- UF.descriptor =<< addNames variable
345+ case structure desc of
346+ Just term ->
347+ case term of
348+ App1 a b -> do
349+ Src.Data name ts <- toSrcType a
350+ b' <- toSrcType b
351+ return (Src.Data name (ts ++ [b']))
352+ Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b
353+ Var1 a -> toSrcType a
354+ EmptyRecord1 -> return Src.EmptyRecord
355+ Record1 fs ext -> do
356+ fs' <- traverse (mapM toSrcType) fs
357+ let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]
358+ Src.Record fs'' <$> toSrcType ext
359+ Nothing ->
360+ case name desc of
361+ Just x@(c:cs) | Char.isLower c -> return (Src.Var x)
362+ | otherwise -> return (Src.Data x [])
363+ Nothing ->
364+ error $ concat
365+ [ "Problem converting the following type "
366+ , "from a type-checker type to a source-syntax type:"
367+ , P.render (pretty Never variable) ]