576bc28 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Print types even when the elm file has already been compiled.

576bc28Justin Leitgeb13 years ago

compiler/Compiler.hs+21−8

compare with master

unifiedsplit

@@ -107,6 +107,14 @@ buildFile flags moduleNum numModules interfaces filePath =

107 bits <- L.hGetContents handle

108 let info :: (String, ModuleInterface)

109 info = Binary.decode bits

110+ modInterface = snd info

111+

112+ when (print_types flags)

113+ (printTypes interfaces

114+ (iTypes modInterface)

115+ (iAliases modInterface)

116+ (iImports modInterface))

117+

110 L.length bits `seq` hClose handle

118 L.length bits `seq` hClose handle

111 return info

119 return info

112 where

120 where

@@ -145,14 +153,19 @@ buildFile flags moduleNum numModules interfaces filePath =

145 False -> return ()

153 False -> return ()

146 True -> print . pretty $ program modul

154 True -> print . pretty $ program modul

147 return modul

155 return modul

148−

156+

149− when (print_types flags) (printTypes interfaces metaModule)

157+ when (print_types flags)

158+ (printTypes interfaces

159+ (types metaModule) (aliases metaModule) (imports metaModule))

160+

150 let interface = Canonical.interface name $ ModuleInterface {

161 let interface = Canonical.interface name $ ModuleInterface {

151− iTypes = types metaModule,

162+ iTypes = types metaModule,

163+ iImports = imports metaModule,

152− iAdts = datatypes metaModule,

164+ iAdts = datatypes metaModule,

153− iAliases = aliases metaModule,

165+ iAliases = aliases metaModule,

154 iFixities = fixities metaModule

166 iFixities = fixities metaModule

155 }

167 }

168+

156 createDirectoryIfMissing True . dropFileName $ elmi flags filePath

169 createDirectoryIfMissing True . dropFileName $ elmi flags filePath

157 handle <- openBinaryFile (elmi flags filePath) WriteMode

170 handle <- openBinaryFile (elmi flags filePath) WriteMode

158 L.hPut handle (Binary.encode (name,interface))

171 L.hPut handle (Binary.encode (name,interface))

@@ -160,10 +173,10 @@ buildFile flags moduleNum numModules interfaces filePath =

160 writeFile (elmo flags filePath) (jsModule metaModule)

173 writeFile (elmo flags filePath) (jsModule metaModule)

161 return (name,interface)

174 return (name,interface)

162

175

163−printTypes interfaces metaModule = do

176+printTypes interfaces moduleTypes moduleAliases moduleImports = do

164 putStrLn ""

177 putStrLn ""

165− let rules = Alias.rules interfaces metaModule

178+ let rules = Alias.rules interfaces moduleAliases moduleImports

166− forM_ (Map.toList $ types metaModule) $ \(n,t) -> do

179+ forM_ (Map.toList moduleTypes) $ \(n,t) -> do

167 print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)

180 print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)

168 putStrLn ""

181 putStrLn ""

169

182

compiler/SourceSyntax/Module.hs+21−1

@@ -12,6 +12,7 @@ import SourceSyntax.Expression (LExpr)

12import SourceSyntax.Declaration

13import SourceSyntax.Type

14import System.FilePath (joinPath)

15+import Control.Monad (liftM)

16data Module tipe var =

17data Module tipe var =

17 Module [String] Exports Imports [Declaration tipe var]

18 Module [String] Exports Imports [Declaration tipe var]

@@ -23,6 +24,22 @@ type Imports = [(String, ImportMethod)]

23data ImportMethod = As String | Importing [String] | Hiding [String]

24data ImportMethod = As String | Importing [String] | Hiding [String]

24 deriving (Eq, Ord, Show, Data, Typeable)

25 deriving (Eq, Ord, Show, Data, Typeable)

27+instance Binary ImportMethod where

28+ put (As s) = do put (0 :: Word8)

29+ put s

30+

31+ put (Importing ss) = do put (1 :: Word8)

32+ put ss

33+

34+ put (Hiding ss) = do put (2 :: Word8)

35+ put ss

36+

37+ get = do tag <- getWord8

38+ case tag of

39+ 0 -> liftM As get

40+ 1 -> liftM Importing get

41+ 2 -> liftM Hiding get

42+

26data MetadataModule t v = MetadataModule {

43data MetadataModule t v = MetadataModule {

27 names :: [String],

44 names :: [String],

28 path :: FilePath,

45 path :: FilePath,

@@ -42,15 +59,18 @@ type ADT = (String, [String], [(String,[Type])])

43data ModuleInterface = ModuleInterface {

60data ModuleInterface = ModuleInterface {

44 iTypes :: Map.Map String Type,

61 iTypes :: Map.Map String Type,

62+ iImports :: [(String, ImportMethod)],

45 iAdts :: [ADT],

63 iAdts :: [ADT],

46 iAliases :: [(String, [String], Type)],

64 iAliases :: [(String, [String], Type)],

47 iFixities :: [(Assoc, Int, String)]

65 iFixities :: [(Assoc, Int, String)]

48} deriving Show

66} deriving Show

68+

50instance Binary ModuleInterface where

69instance Binary ModuleInterface where

51− get = ModuleInterface <$> get <*> get <*> get <*> get

70+ get = ModuleInterface <$> get <*> get <*> get <*> get <*> get

52 put modul = do

71 put modul = do

53 put (iTypes modul)

72 put (iTypes modul)

73+ put (iImports modul)

54 put (iAdts modul)

74 put (iAdts modul)

55 put (iAliases modul)

75 put (iAliases modul)

56 put (iFixities modul)

76 put (iFixities modul)

compiler/Transform/Canonicalize.hs+1

@@ -20,6 +20,7 @@ interface :: String -> ModuleInterface -> ModuleInterface

20interface moduleName iface =

21 ModuleInterface

22 { iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))

23+ , iImports = iImports iface

23 , iAdts = map (both prefix renameCtors) (iAdts iface)

24 , iAdts = map (both prefix renameCtors) (iAdts iface)

24 , iAliases = map (both prefix renameType') (iAliases iface)

25 , iAliases = map (both prefix renameType') (iAliases iface)

25 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

26 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

compiler/Type/Alias.hs+13−9

@@ -11,20 +11,23 @@ import SourceSyntax.Module

12type Rules = ([(String,[String],Type)], Type -> Type)

14+rules interfaces moduleAliases moduleImports =

14−rules interfaces metaModule = (collect interfaces metaModule, localizer metaModule)

15+ (collect interfaces moduleAliases, localizer moduleImports)

17+collect interfaces moduleAliases =

16−collect interfaces metaModule = filter (not . isPrimitive) rawAliases

18+ filter (not . isPrimitive) rawAliases

17− where

19+ where

20+ rawAliases =

18− rawAliases = aliases metaModule ++ concatMap iAliases (Map.elems interfaces)

21+ moduleAliases ++ concatMap iAliases (Map.elems interfaces)

20− isPrimitive (_,_,tipe) =

23+ isPrimitive (_,_,tipe) =

21− case tipe of

24+ case tipe of

22 Data _ [] -> True

25 Data _ [] -> True

23 _ -> False

26 _ -> False

25−localizer metaModule = go

28+localizer moduleImports = go

26 where

29 where

27− go tipe =

30+ go tipe =

28 case tipe of

31 case tipe of

29 Var _ -> tipe

32 Var _ -> tipe

30 EmptyRecord -> tipe

33 EmptyRecord -> tipe

@@ -32,7 +35,8 @@ localizer metaModule = go

32 Data name ts -> Data (localize name) (map go ts)

35 Data name ts -> Data (localize name) (map go ts)

33 Record fs ext -> Record (map (second go) fs) (go ext)

36 Record fs ext -> Record (map (second go) fs) (go ext)

35− byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d) Map.empty (imports metaModule)

38+ byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)

39+ Map.empty moduleImports

37 separate name =

41 separate name =

38 case List.elemIndices '.' name of

42 case List.elemIndices '.' name of

compiler/Type/Inference.hs+1−1

@@ -52,7 +52,7 @@ infer interfaces modul = unsafePerformIO $ do

52 Left err -> return $ Left err

53 Right (header, constraint) -> do

54 state <- execStateT (Solve.solve constraint) TS.initialState

55− let rules = Alias.rules interfaces modul

55+ let rules = Alias.rules interfaces (aliases modul) (imports modul)

56 case TS.sErrors state of

57 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

58 [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)