22f7f8a · elk · git.iko.soy

git.iko.soy/elk

Create a serializable interface for a module's type information

Also add a flag to print out top-level types

commit22f7f8a43a969ec8d1d05774a72b3c2fd18098ea authorEvan Czaplicki <info@elm-lang.org> dateSun 21 Jul 2013, 06:08 (13 years ago) parent0c14f6e

7 files changed+96−38

compare with master

unifiedsplit

Elm.cabal+3 compiler/Compiler.hs+31−23 compiler/Language/Elm.hs+4−3 compiler/Parse/Type.hs+6 compiler/SourceSyntax/Module.hs+13−2 compiler/SourceSyntax/Type.hs+26−1 compiler/Type/Type.hs+13−9

Elm.cabal+3

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

7575 Paths_Elm

7676

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

78+ binary,

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

7980 blaze-markup == 0.5.1.*,

8081 bytestring,

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

142143 Paths_Elm

143144

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

146+ binary,

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

146148 blaze-markup == 0.5.1.*,

147149 bytestring,

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

176178 Parse.Module

177179

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

181+ binary,

179182 containers >= 0.3,

180183 transformers >= 0.2,

181184 mtl >= 2,

compiler/Compiler.hs+31−23

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

44import Control.Monad

55import qualified Data.Map as Map

66import qualified Data.List as List

7+import Data.Binary (encodeFile, decodeFile)

78import Data.Version (showVersion)

89import System.Console.CmdArgs

910import System.Directory

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

2324

2425import Text.PrettyPrint as P

2526import qualified Type.Type as Type

26−

27+import qualified Parse.Type as Parse

28+import qualified Data.Traversable as Traverse

2729

2830data Flags =

2931 Flags { make :: Bool

3032 , files :: [FilePath]

3133 , runtime :: Maybe FilePath

3234 , only_js :: Bool

35+ , print_types :: Bool

3336 , scripts :: [FilePath]

3437 , no_prelude :: Bool

3538 , minify :: Bool

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

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

4649 , only_js = False

4750 &= help "Compile only to JavaScript."

51+ , print_types = False

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

4853 , scripts = [] &= typFile

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

5055 , no_prelude = False

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

6671 fs -> mapM_ (build flags) fs

6772

6873

69−type Interface = String

70−

7174file :: Flags -> FilePath -> String -> FilePath

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

7376

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

7679elmi flags filePath = file flags filePath "elmi"

7780

7881

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

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

8083buildFile flags moduleNum numModules filePath =

8184 do compiled <- alreadyCompiled

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

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

8386

8487 where

8588 alreadyCompiled :: IO Bool

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

9699 name :: String

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

98101

99− compile :: IO Interface

102+ compile :: IO ModuleInterface

100103 compile = do

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

102105 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)

108106 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

109120 writeFile (elmo flags filePath) js

110− writeTypes maybeModule

111− return js

121+ return interface

112122

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

114− writeTypes maybeModule =

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

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

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

123+toSrcTypes tipes = Traverse.traverse convert tipes

124+ where

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

122126

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

123131

124132

125133getRuntime :: Flags -> IO FilePath

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

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

158166

159167

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

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

161169buildFiles _ _ _ [] = return ()

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

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

compiler/Language/Elm.hs+4−3

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

1111-}

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

1313

14−import Data.List (intercalate)

14+import qualified Data.List as List

15+import qualified Data.Map as Map

1516import Data.Version (showVersion)

1617import Generate.JavaScript (showErr, jsModule)

1718import Generate.Html (generateHtml)

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

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

2930compile :: String -> Either String String

3031compile source =

31− case buildFromSource False source of

32+ case buildFromSource Map.empty source of

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

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

3435

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

4142 getModuleName = do

4243 optional freshLine

4344 (names, _) <- moduleDef

44− return (intercalate "." names)

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

4546

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

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

compiler/Parse/Type.hs+6

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

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

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

7474 <*> 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 @@

22module SourceSyntax.Module where

44import Data.Data

5+import Data.Binary

56import Data.List (intercalate)

67import qualified Data.Map as Map

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

810import SourceSyntax.Expression

911import SourceSyntax.Declaration

1012import SourceSyntax.Type

1113import System.FilePath (joinPath)

12−import qualified Type.Type as T

14+import qualified Type.Type as Type

1315

1416data Module tipe var =

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

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

2729 exports :: [String],

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

2931 program :: LExpr t v,

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

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

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

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

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

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

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

3638}

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 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22module SourceSyntax.Type where

4+import Data.Binary

45import Data.Data

56import qualified Data.Map as Map

67import qualified SourceSyntax.Helpers as Help

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

79import SourceSyntax.PrettyPrint

810import Text.PrettyPrint as P

911

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

5355 case tipe of

5456 Lambda _ _ -> True

5557 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 ((<$>),(<*>))

1010import Control.Monad.State

1111import Data.Traversable (traverse)

1212import SourceSyntax.Helpers (isTuple)

13+import qualified SourceSyntax.Type as Src

1314

1415data Term1 a

1516 = App1 a a

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

2627

2728record fs rec = TermN (Record1 fs rec)

2829

30+type Type = TermN Variable

31+type Variable = UF.Point Descriptor

32+

2933type SchemeName = String

3034type TypeName = String

3135

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

4549 header :: Map.Map String a

4650} deriving Show

4751

52+type TypeConstraint = Constraint Type Variable

53+type TypeScheme = Scheme Type Variable

54+

4855monoscheme headers = Scheme [] [] CTrue headers

4956

5057data Descriptor = Descriptor {

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

6572data Flex = Rigid | Flexible | Constant

6673 deriving (Show, Eq)

6774

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−

7475infixl 8 /\

7576

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

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

241242

242243

243244extraPretty :: (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

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

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

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

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

249253 okayVars = filter (`notElem` vars) allVars

250254 runStateT (crawl rename value) okayVars

251− return (pretty Never value)

255+ return value

252256 where

253257 getNames name vars =

254258 case name of

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

259263 case name of

260264 Just var -> (name, vars)

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

262−--}

266+

263267

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

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