22f7f8a · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Create a serializable interface for a module's type information

22f7f8aEvan Czaplicki13 years ago

Elm.cabal+3

compare with master

unifiedsplit

@@ -75,6 +75,7 @@ Library

75 Paths_Elm

77 Build-depends: base >=4.2 && <5,

78+ binary,

78 blaze-html == 0.5.* || == 0.6.*,

79 blaze-html == 0.5.* || == 0.6.*,

79 blaze-markup == 0.5.1.*,

80 blaze-markup == 0.5.1.*,

80 bytestring,

81 bytestring,

@@ -142,6 +143,7 @@ Executable elm

142 Paths_Elm

143 Paths_Elm

143

144

144 Build-depends: base >=4.2 && <5,

145 Build-depends: base >=4.2 && <5,

146+ binary,

145 blaze-html == 0.5.* || == 0.6.*,

147 blaze-html == 0.5.* || == 0.6.*,

146 blaze-markup == 0.5.1.*,

148 blaze-markup == 0.5.1.*,

147 bytestring,

149 bytestring,

@@ -176,6 +178,7 @@ Executable elm-doc

176 Parse.Module

178 Parse.Module

177

179

178 Build-depends: base >=4.2 && <5,

180 Build-depends: base >=4.2 && <5,

181+ binary,

179 containers >= 0.3,

182 containers >= 0.3,

180 transformers >= 0.2,

183 transformers >= 0.2,

181 mtl >= 2,

184 mtl >= 2,

compiler/Compiler.hs+31−23

@@ -4,6 +4,7 @@ module Main where

4import Control.Monad

5import qualified Data.Map as Map

6import qualified Data.List as List

7+import Data.Binary (encodeFile, decodeFile)

7import Data.Version (showVersion)

8import Data.Version (showVersion)

8import System.Console.CmdArgs

9import System.Console.CmdArgs

9import System.Directory

10import System.Directory

@@ -23,13 +24,15 @@ import Paths_Elm

24import Text.PrettyPrint as P

25import Text.PrettyPrint as P

25import qualified Type.Type as Type

26import qualified Type.Type as Type

26−

27+import qualified Parse.Type as Parse

28+import qualified Data.Traversable as Traverse

28data Flags =

30data Flags =

29 Flags { make :: Bool

31 Flags { make :: Bool

30 , files :: [FilePath]

32 , files :: [FilePath]

31 , runtime :: Maybe FilePath

33 , runtime :: Maybe FilePath

32 , only_js :: Bool

34 , only_js :: Bool

35+ , print_types :: Bool

33 , scripts :: [FilePath]

36 , scripts :: [FilePath]

34 , no_prelude :: Bool

37 , no_prelude :: Bool

35 , minify :: Bool

38 , minify :: Bool

@@ -45,6 +48,8 @@ flags = Flags

45 &= help "Specify a custom location for Elm's runtime system."

48 &= help "Specify a custom location for Elm's runtime system."

46 , only_js = False

49 , only_js = False

47 &= help "Compile only to JavaScript."

50 &= help "Compile only to JavaScript."

51+ , print_types = False

52+ &= help "Print out infered types of top-level definitions."

48 , scripts = [] &= typFile

53 , scripts = [] &= typFile

49 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."

54 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."

50 , no_prelude = False

55 , no_prelude = False

@@ -66,8 +71,6 @@ compileArgs flags =

66 fs -> mapM_ (build flags) fs

71 fs -> mapM_ (build flags) fs

69−type Interface = String

70−

71file :: Flags -> FilePath -> String -> FilePath

74file :: Flags -> FilePath -> String -> FilePath

72file flags filePath ext = output_directory flags </> replaceExtension filePath ext

75file flags filePath ext = output_directory flags </> replaceExtension filePath ext

@@ -76,10 +79,10 @@ elmo flags filePath = file flags filePath "elmo"

76elmi flags filePath = file flags filePath "elmi"

79elmi flags filePath = file flags filePath "elmi"

79−buildFile :: Flags -> Int -> Int -> FilePath -> IO Interface

82+buildFile :: Flags -> Int -> Int -> FilePath -> IO ModuleInterface

80buildFile flags moduleNum numModules filePath =

83buildFile flags moduleNum numModules filePath =

81 do compiled <- alreadyCompiled

84 do compiled <- alreadyCompiled

82− if compiled then readFile (elmo flags filePath) else compile

85+ if compiled then decodeFile (elmi flags filePath) else compile

84 where

87 where

85 alreadyCompiled :: IO Bool

88 alreadyCompiled :: IO Bool

@@ -96,30 +99,35 @@ buildFile flags moduleNum numModules filePath =

96 name :: String

99 name :: String

97 name = List.intercalate "." (splitDirectories (dropExtensions filePath))

100 name = List.intercalate "." (splitDirectories (dropExtensions filePath))

101

99− compile :: IO Interface

102+ compile :: IO ModuleInterface

100 compile = do

103 compile = do

101 putStrLn (number ++ " Compiling " ++ name)

104 putStrLn (number ++ " Compiling " ++ name)

102 source <- readFile filePath

105 source <- readFile filePath

103− (js, maybeModule) <-

104− if takeExtension filePath == ".js" then return (source, Nothing) else

105− case buildFromSource (no_prelude flags) source of

106− Left err -> mapM print err >> exitFailure

107− Right modul -> return (jsModule modul, Just modul)

108 createDirectoryIfMissing True (output_directory flags)

106 createDirectoryIfMissing True (output_directory flags)

107+ metaModule <-

108+ case buildFromSource Map.empty source of

109+ Left err -> mapM print err >> exitFailure

110+ Right modul -> return (modul :: MetadataModule () ())

111+ if print_types flags then printTypes metaModule else return ()

112+ tipes <- toSrcTypes (types metaModule)

113+ let fmt (name, tvars, ctors) = (name, (length tvars, map fst ctors))

114+ interface = ModuleInterface {

115+ iTypes = tipes,

116+ iAdts = Map.fromList . map fmt $ datatypes metaModule

117+ }

118+ encodeFile (elmi flags filePath) interface

119+ let js = jsModule metaModule

109 writeFile (elmo flags filePath) js

120 writeFile (elmo flags filePath) js

110− writeTypes maybeModule

111− return js

121+ return interface

112

122

113− writeTypes :: Maybe (MetadataModule () ()) -> IO ()

123+toSrcTypes tipes = Traverse.traverse convert tipes

114− writeTypes maybeModule =

124+ where

115− case maybeModule of

116− Nothing -> return ()

117− Just metaModule -> do

118− tipes <- forM (Map.toList (types metaModule)) $ \(n,t) -> do

119− pt <- Type.extraPretty t

125+ convert t = fmap (Parse.readType . P.render) (Type.extraPretty t)

120− return $ P.text n <+> P.text ":" <+> pt

121− writeFile (elmi flags filePath) (P.render $ P.vcat tipes)

122

126

127+printTypes metaModule =

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

129+ pt <- Type.extraPretty t

130+ print $ P.text n <+> P.text ":" <+> pt

123

131

124

132

125getRuntime :: Flags -> IO FilePath

133getRuntime :: Flags -> IO FilePath

@@ -157,7 +165,7 @@ build flags rootFile = do

157 [ Source (if minify flags then Minified else Readable) js ]

165 [ Source (if minify flags then Minified else Readable) js ]

158

166

159

167

160−buildFiles :: Flags -> Int -> Map.Map String Interface -> [FilePath] -> IO ()

168+buildFiles :: Flags -> Int -> Map.Map String ModuleInterface -> [FilePath] -> IO ()

161buildFiles _ _ _ [] = return ()

169buildFiles _ _ _ [] = return ()

162buildFiles flags numModules interfaces (filePath:rest) = do

170buildFiles flags numModules interfaces (filePath:rest) = do

163 interface <- buildFile flags (numModules - length rest) numModules filePath

171 interface <- buildFile flags (numModules - length rest) numModules filePath

compiler/Language/Elm.hs+4−3

@@ -11,7 +11,8 @@

11-}

12module Language.Elm (compile, toHtml, moduleName, runtime, docs) where

14−import Data.List (intercalate)

14+import qualified Data.List as List

15+import qualified Data.Map as Map

15import Data.Version (showVersion)

16import Data.Version (showVersion)

16import Generate.JavaScript (showErr, jsModule)

17import Generate.JavaScript (showErr, jsModule)

17import Generate.Html (generateHtml)

18import Generate.Html (generateHtml)

@@ -28,7 +29,7 @@ import Paths_Elm

28-- an error message or the compiled JS code.

29-- an error message or the compiled JS code.

29compile :: String -> Either String String

30compile :: String -> Either String String

30compile source =

31compile source =

31− case buildFromSource False source of

32+ case buildFromSource Map.empty source of

32 Left docs -> Left . unlines $ map P.render docs

33 Left docs -> Left . unlines $ map P.render docs

33 Right modul -> Right $ jsModule (modul :: MetadataModule () ())

34 Right modul -> Right $ jsModule (modul :: MetadataModule () ())

@@ -41,7 +42,7 @@ moduleName source = case iParse getModuleName "" source of

41 getModuleName = do

42 getModuleName = do

42 optional freshLine

43 optional freshLine

43 (names, _) <- moduleDef

44 (names, _) <- moduleDef

44− return (intercalate "." names)

45+ return (List.intercalate "." names)

46-- |This function compiles Elm code into a full HTML page.

47-- |This function compiles Elm code into a full HTML page.

47toHtml :: String -- ^ Location of elm-min.js as expected by the browser

48toHtml :: String -- ^ Location of elm-min.js as expected by the browser

compiler/Parse/Type.hs+6

@@ -72,3 +72,9 @@ expr =

72constructor :: IParser (String, [T.Type])

73constructor = (,) <$> (capVar <?> "another type constructor")

74 <*> spacePrefix term

75+

76+readType :: String -> Type

77+readType str =

78+ case iParse expr "" str of

79+ Left err -> error (show err)

80+ Right tipe -> tipe

compiler/SourceSyntax/Module.hs+13−2

@@ -2,14 +2,16 @@

2module SourceSyntax.Module where

4import Data.Data

5+import Data.Binary

5import Data.List (intercalate)

6import Data.List (intercalate)

6import qualified Data.Map as Map

7import qualified Data.Map as Map

8+import Control.Applicative ((<$>), (<*>))

8import SourceSyntax.Expression

10import SourceSyntax.Expression

9import SourceSyntax.Declaration

11import SourceSyntax.Declaration

10import SourceSyntax.Type

12import SourceSyntax.Type

11import System.FilePath (joinPath)

13import System.FilePath (joinPath)

12−import qualified Type.Type as T

14+import qualified Type.Type as Type

14data Module tipe var =

16data Module tipe var =

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

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

@@ -27,10 +29,19 @@ data MetadataModule t v = MetadataModule {

27 exports :: [String],

29 exports :: [String],

28 imports :: [(String, ImportMethod)],

30 imports :: [(String, ImportMethod)],

29 program :: LExpr t v,

31 program :: LExpr t v,

30− types :: Map.Map String T.Variable,

32+ types :: Map.Map String Type.Variable,

31 fixities :: [(Assoc, Int, String)],

33 fixities :: [(Assoc, Int, String)],

32 aliases :: [(String, [String], Type)],

34 aliases :: [(String, [String], Type)],

33 datatypes :: [ (String, [String], [(String,[Type])]) ],

35 datatypes :: [ (String, [String], [(String,[Type])]) ],

34 foreignImports :: [(String, LExpr t v, String, Type)],

36 foreignImports :: [(String, LExpr t v, String, Type)],

35 foreignExports :: [(String, String, Type)]

37 foreignExports :: [(String, String, Type)]

36}

38}

39+

40+data ModuleInterface = ModuleInterface {

41+ iTypes :: Map.Map String Type,

42+ iAdts :: Map.Map String (Int, [String])

43+} deriving Show

44+

45+instance Binary ModuleInterface where

46+ put modul = put (iTypes modul) >> put (iAdts modul)

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

compiler/SourceSyntax/Type.hs+26−1

@@ -1,9 +1,11 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2module SourceSyntax.Type where

4+import Data.Binary

4import Data.Data

5import Data.Data

5import qualified Data.Map as Map

6import qualified Data.Map as Map

6import qualified SourceSyntax.Helpers as Help

7import qualified SourceSyntax.Helpers as Help

8+import Control.Applicative ((<$>), (<*>))

7import SourceSyntax.PrettyPrint

9import SourceSyntax.PrettyPrint

8import Text.PrettyPrint as P

10import Text.PrettyPrint as P

@@ -53,4 +55,27 @@ prettyParens tipe = parensIf needed (pretty tipe)

53 case tipe of

55 case tipe of

54 Lambda _ _ -> True

56 Lambda _ _ -> True

55 Data _ _ -> True

57 Data _ _ -> True

56− _ -> False

58+ _ -> False

59+

60+instance Binary Type where

61+ put tipe =

62+ case tipe of

63+ Lambda t1 t2 ->

64+ putWord8 0 >> put t1 >> put t2

65+ Var x ->

66+ putWord8 1 >> put x

67+ Data ctor tipes ->

68+ putWord8 2 >> put ctor >> put tipes

69+ EmptyRecord ->

70+ putWord8 3

71+ Record fs ext ->

72+ putWord8 4 >> put fs >> put ext

73+

74+ get = do

75+ n <- getWord8

76+ case n of

77+ 0 -> Lambda <$> get <*> get

78+ 1 -> Var <$> get

79+ 2 -> Data <$> get <*> get

80+ 3 -> return EmptyRecord

81+ 4 -> Record <$> get <*> get

compiler/Type/Type.hs+13−9

@@ -10,6 +10,7 @@ import Control.Applicative ((<$>),(<*>))

10import Control.Monad.State

11import Data.Traversable (traverse)

12import SourceSyntax.Helpers (isTuple)

13+import qualified SourceSyntax.Type as Src

14data Term1 a

15data Term1 a

15 = App1 a a

16 = App1 a a

@@ -26,6 +27,9 @@ data TermN a

27record fs rec = TermN (Record1 fs rec)

28record fs rec = TermN (Record1 fs rec)

30+type Type = TermN Variable

31+type Variable = UF.Point Descriptor

32+

29type SchemeName = String

33type SchemeName = String

30type TypeName = String

34type TypeName = String

@@ -45,6 +49,9 @@ data Scheme a b = Scheme {

45 header :: Map.Map String a

49 header :: Map.Map String a

46} deriving Show

50} deriving Show

52+type TypeConstraint = Constraint Type Variable

53+type TypeScheme = Scheme Type Variable

54+

48monoscheme headers = Scheme [] [] CTrue headers

55monoscheme headers = Scheme [] [] CTrue headers

50data Descriptor = Descriptor {

57data Descriptor = Descriptor {

@@ -65,12 +72,6 @@ initialMark = 1

65data Flex = Rigid | Flexible | Constant

72data Flex = Rigid | Flexible | Constant

66 deriving (Show, Eq)

73 deriving (Show, Eq)

68−type Variable = UF.Point Descriptor

69−

70−type Type = TermN Variable

71−type TypeConstraint = Constraint Type Variable

72−type TypeScheme = Scheme Type Variable

73−

74infixl 8 /\

75infixl 8 /\

76(/\) :: Constraint a b -> Constraint a b -> Constraint a b

77(/\) :: Constraint a b -> Constraint a b -> Constraint a b

@@ -241,14 +242,17 @@ instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

241

242

243

243extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc

244extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc

244−extraPretty value = do

245+extraPretty t = pretty Never <$> addNames t

246+

247+addNames :: (Crawl t) => t -> IO t

248+addNames value = do

245 (_, rawVars) <- runStateT (crawl getNames value) []

249 (_, rawVars) <- runStateT (crawl getNames value) []

246 let vars = map head . List.group $ List.sort rawVars

250 let vars = map head . List.group $ List.sort rawVars

247 suffix s = map (++s) (map (:[]) ['a'..'z'])

251 suffix s = map (++s) (map (:[]) ['a'..'z'])

248 allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]

252 allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]

249 okayVars = filter (`notElem` vars) allVars

253 okayVars = filter (`notElem` vars) allVars

250 runStateT (crawl rename value) okayVars

254 runStateT (crawl rename value) okayVars

251− return (pretty Never value)

255+ return value

252 where

256 where

253 getNames name vars =

257 getNames name vars =

254 case name of

258 case name of

@@ -259,7 +263,7 @@ extraPretty value = do

259 case name of

263 case name of

260 Just var -> (name, vars)

264 Just var -> (name, vars)

261 Nothing -> (Just (head vars), tail vars)

265 Nothing -> (Just (head vars), tail vars)

262−--}

266+

263

267

264-- Code for traversing all the type data-structures and giving

268-- Code for traversing all the type data-structures and giving

265-- names to the variables embedded deep in there.

269-- names to the variables embedded deep in there.