c215b4f · elk · git.iko.soy

git.iko.soy/elk

Get canonicalization of modules compiling

commitc215b4fbf2d9e30a705602bd8437f688dbe48718 authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 31 Oct 2017, 20:27 (9 years ago) parent4c79ddd

6 files changed+291−210

compare with master

unifiedsplit

src/AST/Expression/Canonical.hs+24−12 src/AST/Expression/Valid.hs+3−3 src/Canonicalize/Body.hs−180 src/Canonicalize/Environment/Foreign.hs+5−5 src/Canonicalize/Module.hs+176−10 src/Elm/Interface.hs+83

src/AST/Expression/Canonical.hs+24−12

@@ -17,7 +17,8 @@ module AST.Expression.Canonical

1717 , Union(..)

1818 , Binop(..)

1919 , Effects(..)

20− , Port(..)

20+ , Exports(..)

21+ , Export(..)

2122 , Docs(..)

2223 )

2324 where

@@ -25,6 +26,7 @@ module AST.Expression.Canonical

2526

2627import Control.Monad (liftM2, liftM3)

2728import Data.Binary

29+import qualified Data.ByteString as B

2830import qualified Data.Map as Map

2931import Data.Text (Text)

3032

@@ -35,7 +37,6 @@ import qualified AST.Type as Type

3537import qualified Elm.Name as N

3638import Elm.Name (Name)

3739import qualified Reporting.Annotation as A

38−import qualified Reporting.Region as R

3940

4041

4142

@@ -142,7 +143,7 @@ data Module =

142143 Module

143144 { _name :: ModuleName.Canonical

144145 , _docs :: A.Located (Maybe Docs)

145− , _imports :: [N.Name]

146+ , _exports :: Exports

146147 , _decls :: Decls

147148 , _unions :: Map.Map N.Name Union

148149 , _aliases :: Map.Map N.Name Alias

@@ -151,19 +152,30 @@ data Module =

151152 }

152153

153154

154−data Alias = Alias [N.Name] Type.Canonical

155+data Alias = Alias [N.Name] Type.Canonical (Maybe [N.Name])

155156data Union = Union [N.Name] [(N.Name, [Type.Canonical])]

156157data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name

157158

158159data Effects

159160 = NoEffects

160− | Ports [Port]

161− | Cmd

162− | Sub

163− | Fx

161+ | Ports (Map.Map N.Name Type.Canonical)

162+ | Cmd N.Name

163+ | Sub N.Name

164+ | Fx N.Name N.Name

164165

165166

166−data Port = Port R.Region N.Name Type.Canonical

167+data Exports

168+ = ExportEverything

169+ | Export (Map.Map N.Name Export)

170+

171+

172+data Export

173+ = ExportValue

174+ | ExportBinop

175+ | ExportAlias

176+ | ExportUnionOpen

177+ | ExportUnionClosed

178+ | ExportPort

167179

168180

169181

@@ -172,7 +184,7 @@ data Port = Port R.Region N.Name Type.Canonical

172184

173185data Docs =

174186 Docs

175− { _overview :: Text

187+ { _overview :: B.ByteString

176188 , _comments :: Map.Map N.Name Text

177189 }

178190

@@ -182,8 +194,8 @@ data Docs =

182194

183195

184196instance Binary Alias where

185− get = liftM2 Alias get get

186− put (Alias a b) = put a >> put b

197+ get = liftM3 Alias get get get

198+ put (Alias a b c) = put a >> put b >> put c

187199

188200

189201instance Binary Union where

src/AST/Expression/Valid.hs+3−3

@@ -91,9 +91,9 @@ data Binop = Binop (A.Located N.Name) Binop.Associativity Binop.Precedence N.Nam

9191data Effects

9292 = NoEffects

9393 | Ports [Port]

94− | Cmd (A.Located Text)

95− | Sub (A.Located Text)

96− | Fx (A.Located Text) (A.Located Text)

94+ | Cmd (A.Located N.Name)

95+ | Sub (A.Located N.Name)

96+ | Fx (A.Located N.Name) (A.Located N.Name)

9797

9898

9999data Port = Port (A.Located N.Name) Type.Raw

src/Canonicalize/Body.hsdeleted−180

@@ -1,180 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Canonicalize.Body (flatten) where

4−

5−import qualified Data.Maybe as Maybe

6−import qualified Data.Text as Text

7−import Data.Text (Text)

8−

9−import qualified AST.Declaration as Decl

10−import qualified AST.Effects as Effects

11−import qualified AST.Expression.Canonical as C

12−import qualified AST.Module.Name as ModuleName

13−import qualified AST.Pattern as P

14−import qualified AST.Type as Type

15−import qualified AST.Variable as Var

16−import qualified Canonicalize.Sort as Sort

17−import qualified Reporting.Annotation as A

18−import Reporting.Error.Canonicalize (Error)

19−import Reporting.Region (Region)

20−import Reporting.Result (Result)

21−

22−

23−

24−flatten

25− :: (Monoid i)

26− => ModuleName.Canonical

27− -> Decl.Canonical

28− -> Effects.Canonical

29− -> Result i w Error C.Expr

30−flatten moduleName (Decl.Decls defs unions aliases _) effects =

31− let

32− allDefs =

33− concat

34− [ concatMap (unionToDefs moduleName) unions

35− , Maybe.mapMaybe (aliasToDefs moduleName) aliases

36− , effectsToDefs moduleName effects

37− , map A.drop defs

38− ]

39−

40− loc =

41− A.A (error "this annotation should never be needed")

42− in

43− Sort.definitions $ loc $

44− C.Let allDefs (loc $ C.SaveEnv moduleName effects)

45−

46−

47−

48−-- TYPES TO DEFS

49−

50−

51−unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [C.Def]

52−unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =

53− let

54− tagToDef (tag, tipes) =

55− let

56− vars =

57− generateArgs (length tipes) []

58−

59− tbody =

60− Type.Type (Var.fromModule moduleName name) (map Type.Var tvars)

61−

62− body =

63− A.A region $

64− C.Ctor (Var.fromModule moduleName tag) (map (A.A region . C.localVar) vars)

65− in

66− definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)

67− in

68− map tagToDef constructors

69−

70−

71−aliasToDefs :: ModuleName.Canonical -> A.Commented (Decl.Alias Type.Canonical) -> Maybe C.Def

72−aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =

73− case tipe of

74− Type.Record fields Nothing ->

75− let

76− resultType =

77− Type.Aliased

78− (Var.fromModule moduleName name)

79− (zip tvars (map Type.Var tvars))

80− (Type.Holey tipe)

81−

82− args =

83− map snd fields

84−

85− vars =

86− generateArgs (length args) []

87−

88− record =

89− A.A region $

90− C.Record (zip (map fst fields) (map (A.A region . C.localVar) vars))

91− in

92− Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)

93−

94− _ ->

95− Nothing

96−

97−

98−generateArgs :: Int -> [Text] -> [Text]

99−generateArgs n args =

100− if n == 0 then

101− args

102− else

103− generateArgs (n - 1) (Text.pack ('v' : show n) : args)

104−

105−

106−buildFunction :: [Text] -> C.Expr -> C.Expr

107−buildFunction vars body@(A.A ann _) =

108− foldr

109− (\pattern expr -> A.A ann (C.Lambda pattern expr))

110− body

111− (map (A.A ann . P.Var) vars)

112−

113−

114−definition :: Text -> C.Expr -> Region -> Type.Canonical -> C.Def

115−definition name expr@(A.A ann _) region tipe =

116− C.Def

117− region

118− (A.A ann (P.Var name))

119− expr

120− (Just (A.A region tipe))

121−

122−

123−

124−-- EFFECTS

125−

126−

127−effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [C.Def]

128−effectsToDefs moduleName effects =

129− case effects of

130− Effects.None ->

131− []

132−

133− Effects.Port ports ->

134− map portToDef ports

135−

136− Effects.Manager _ info ->

137− let

138− cmdToDef (A.A region name) managerType =

139− definition

140− "command"

141− (A.A region (C.Cmd moduleName managerType))

142− region

143− (Type.cmd moduleName name)

144−

145− subToDef (A.A region name) managerType =

146− definition

147− "subscription"

148− (A.A region (C.Sub moduleName managerType))

149− region

150− (Type.sub moduleName name)

151− in

152− case Effects._managerType info of

153− Effects.CmdManager cmd ->

154− [ cmdToDef cmd Effects.Cmds

155− ]

156−

157− Effects.SubManager sub ->

158− [ subToDef sub Effects.Subs

159− ]

160−

161− Effects.FxManager cmd sub ->

162− [ cmdToDef cmd Effects.Both

163− , subToDef sub Effects.Both

164− ]

165−

166−

167−portToDef :: A.Commented Effects.PortCanonical -> C.Def

168−portToDef (A.A (region, _) (Effects.PortCanonical name kind tipe)) =

169− definition name (A.A region (toPortExpr name kind)) region tipe

170−

171−

172−toPortExpr :: Text -> Effects.Kind -> C.Expr'

173−toPortExpr name kind =

174− case kind of

175− Effects.Outgoing tipe ->

176− C.OutgoingPort name tipe

177−

178− Effects.Incoming tipe ->

179− C.IncomingPort name tipe

180−

src/Canonicalize/Environment/Foreign.hs+5−5

@@ -88,7 +88,7 @@ createInitialEnv home importDict interfaces sourceImports =

8888

8989

9090importToEnv :: Import -> Env

91−importToEnv (Import home (I.Interface _ types unions aliases binops) prefix exposing) =

91+importToEnv (Import home (I.Interface types unions aliases binops) prefix exposing) =

9292 let

9393 patterns =

9494 let dector (Can.Union _ ctors) = map (fmap length) ctors in

@@ -160,7 +160,7 @@ toUnionInfo home (Can.Union args _) =

160160

161161

162162toAliasInfo :: ModuleName.Canonical -> Can.Alias -> ( Env.Type, Int )

163−toAliasInfo home (Can.Alias args tipe) =

163+toAliasInfo home (Can.Alias args tipe _) =

164164 ( Env.Alias home args tipe, length args )

165165

166166

@@ -277,7 +277,7 @@ throwImportNotFound region name knownModules =

277277

278278

279279verifyExposed :: ModuleName.Raw -> I.Interface -> A.Located Src.Exposed -> Result [(N.Name, Exposed)]

280−verifyExposed moduleName interface@(I.Interface _ _ unions aliases _) (A.A region exposed) =

280+verifyExposed moduleName interface@(I.Interface _ unions aliases _) (A.A region exposed) =

281281 case exposed of

282282 Src.Operator name ->

283283 verifyValue moduleName region name interface

@@ -301,7 +301,7 @@ verifyExposed moduleName interface@(I.Interface _ _ unions aliases _) (A.A regio

301301

302302

303303verifyValue :: ModuleName.Raw -> R.Region -> N.Name -> I.Interface -> Result [(N.Name, Exposed)]

304−verifyValue moduleName region name interface@(I.Interface _ types _ _ _) =

304+verifyValue moduleName region name interface@(I.Interface types _ _ _) =

305305 case Map.lookup name types of

306306 Nothing ->

307307 throwExposingNotFound moduleName region name interface

@@ -321,7 +321,7 @@ verifyAlias region name privacy =

321321

322322

323323throwExposingNotFound :: ModuleName.Raw -> R.Region -> N.Name -> I.Interface -> Result a

324−throwExposingNotFound moduleName region name (I.Interface _ types unions aliases _) =

324+throwExposingNotFound moduleName region name (I.Interface types unions aliases _) =

325325 let

326326 toCtorPairs (tipe, Can.Union _ ctors) =

327327 map (\(ctor, _) -> (ctor, tipe)) ctors

src/Canonicalize/Module.hs+176−10

@@ -10,10 +10,12 @@ import qualified Data.Map as Map

1010import qualified Data.Set as Set

1111

1212import qualified AST.Expression.Canonical as Can

13+import qualified AST.Expression.Source as Src

1314import qualified AST.Expression.Valid as Valid

1415import qualified AST.Module.Name as ModuleName

1516import qualified AST.Type as Type

1617import qualified Canonicalize.Environment as Env

18+import qualified Canonicalize.Environment.Dups as Dups

1719import qualified Canonicalize.Expression as Expr

1820import qualified Canonicalize.Pattern as Pattern

1921import qualified Canonicalize.Type as Type

@@ -47,15 +49,34 @@ canonicalize

4749 -> Result Can.Module

4850canonicalize pkg importDict interfaces module_ =

4951 do env <- Env.create pkg importDict interfaces module_

50− let (Valid.Module name _ _ _ _ decls unions aliases binops _) = module_

51− Can.Module (ModuleName.Canonical pkg name)

52− <$> error "TODO docs"

53− <*> error "TODO imports"

54− <*> canonicalizeDecls env decls

55− <*> (Map.fromList <$> traverse (canonicalizeUnion env) unions)

56− <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)

57− <*> return (Map.fromList (map canonicalizeBinop binops))

58− <*> error "TODO effects"

52+ let (Valid.Module name _ _ exports _ decls unions aliases binops effects) = module_

53+ (cdecls, cunions, caliases) <-

54+ (,,)

55+ <$> canonicalizeDecls env decls

56+ <*> (Map.fromList <$> traverse (canonicalizeUnion env) unions)

57+ <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)

58+

59+ let cbinops = Map.fromList (map canonicalizeBinop binops)

60+ ceffects <- canonicalizeEffects env cunions effects

61+ cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports

62+

63+ let home = ModuleName.Canonical pkg name

64+ let docs = toDocs module_

65+ return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects

66+

67+

68+

69+-- DOCUMENTATION

70+

71+

72+toDocs :: Valid.Module -> A.Located (Maybe Can.Docs)

73+toDocs (Valid.Module _ (A.A region maybeOverview) comments _ _ _ _ _ _ _) =

74+ case maybeOverview of

75+ Nothing ->

76+ A.A region Nothing

77+

78+ Just overview ->

79+ A.A region (Just (Can.Docs overview comments))

5980

6081

6182

@@ -65,7 +86,17 @@ canonicalize pkg importDict interfaces module_ =

6586canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )

6687canonicalizeAlias env (Valid.Alias (A.A _ name) args tipe) =

6788 do ctipe <- Type.canonicalize env tipe

68− return (name, Can.Alias (map A.drop args) ctipe)

89+ return (name, Can.Alias (map A.drop args) ctipe (toRecordCtorInfo tipe))

90+

91+

92+toRecordCtorInfo :: Type.Raw -> Maybe [N.Name]

93+toRecordCtorInfo (A.A _ tipe) =

94+ case tipe of

95+ Type.RRecord fields Nothing ->

96+ Just (map (A.drop . fst) fields)

97+

98+ _ ->

99+ Nothing

69100

70101

71102

@@ -178,3 +209,138 @@ detectBadCyclesHelp decl =

178209

179210 Function _ _ _ _ ->

180211 Nothing

212+

213+

214+

215+-- CANONICALIZE EFFECTS

216+

217+

218+canonicalizeEffects :: Env.Env -> Map.Map N.Name a -> Valid.Effects -> Result Can.Effects

219+canonicalizeEffects env unions effects =

220+ case effects of

221+ Valid.NoEffects ->

222+ Result.ok Can.NoEffects

223+

224+ Valid.Ports ports ->

225+ do pairs <- traverse (canonicalizePort env) ports

226+ return $ Can.Ports (Map.fromList pairs)

227+

228+ Valid.Cmd cmdType ->

229+ Can.Cmd <$> verifyEffectType cmdType unions

230+

231+ Valid.Sub subType ->

232+ Can.Sub <$> verifyEffectType subType unions

233+

234+ Valid.Fx cmdType subType ->

235+ Can.Fx

236+ <$> verifyEffectType cmdType unions

237+ <*> verifyEffectType subType unions

238+

239+

240+canonicalizePort :: Env.Env -> Valid.Port -> Result (N.Name, Type.Canonical)

241+canonicalizePort env (Valid.Port (A.A _ name) tipe) =

242+ (,) name <$> Type.canonicalize env tipe

243+

244+

245+verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result N.Name

246+verifyEffectType (A.A region name) unions =

247+ if Map.member name unions then

248+ Result.ok name

249+ else

250+ Result.throw region (Error.EffectNotFound name)

251+

252+

253+

254+-- CANONICALIZE EXPORTS

255+

256+

257+canonicalizeExports

258+ :: [A.Located Valid.Decl]

259+ -> Map.Map N.Name union

260+ -> Map.Map N.Name alias

261+ -> Map.Map N.Name binop

262+ -> Can.Effects

263+ -> Src.Exposing

264+ -> Result Can.Exports

265+canonicalizeExports decls unions aliases binops effects exposing =

266+ case exposing of

267+ Src.Open ->

268+ Result.ok Can.ExportEverything

269+

270+ Src.Explicit exposeds ->

271+ do let names = Map.fromList (map declToName decls)

272+ infos <- traverse (checkExposed names unions aliases binops effects) exposeds

273+ let toError name () () = Error.ExportDuplicate name

274+ Can.Export <$> Dups.detect toError infos

275+

276+

277+declToName :: A.Located Valid.Decl -> (N.Name, Can.Export)

278+declToName (A.A _ (Valid.Decl (A.A _ name) _ _ _)) =

279+ (name, Can.ExportValue)

280+

281+

282+checkExposed

283+ :: Map.Map N.Name decl

284+ -> Map.Map N.Name union

285+ -> Map.Map N.Name alias

286+ -> Map.Map N.Name binop

287+ -> Can.Effects

288+ -> A.Located Src.Exposed

289+ -> Result (N.Name, [Dups.Info () Can.Export])

290+checkExposed decls unions aliases binops effects (A.A region exposed) =

291+ case exposed of

292+ Src.Lower name ->

293+ if Map.member name decls then

294+ Result.ok (Dups.info name region () Can.ExportValue)

295+ else

296+ case checkPorts effects name of

297+ Nothing ->

298+ Result.ok (Dups.info name region () Can.ExportPort)

299+

300+ Just ports ->

301+ Result.throw region $ Error.ExportNotFound Error.BadVar name $

302+ ports ++ Map.keys decls

303+

304+ Src.Operator name ->

305+ if Map.member name binops then

306+ Result.ok (Dups.info name region () Can.ExportBinop)

307+ else

308+ Result.throw region $ Error.ExportNotFound Error.BadOp name $

309+ Map.keys binops

310+

311+ Src.Upper name Src.Public ->

312+ if Map.member name unions then

313+ Result.ok (Dups.info name region () Can.ExportUnionOpen)

314+ else if Map.member name aliases then

315+ Result.throw region $ Error.ExportOpenAlias name

316+ else

317+ Result.throw region $ Error.ExportNotFound Error.BadType name $

318+ Map.keys unions ++ Map.keys aliases

319+

320+ Src.Upper name Src.Private ->

321+ if Map.member name unions then

322+ Result.ok (Dups.info name region () Can.ExportUnionClosed)

323+ else if Map.member name aliases then

324+ Result.ok (Dups.info name region () Can.ExportAlias)

325+ else

326+ Result.throw region $ Error.ExportNotFound Error.BadType name $

327+ Map.keys unions ++ Map.keys aliases

328+

329+

330+checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]

331+checkPorts effects name =

332+ case effects of

333+ Can.NoEffects ->

334+ Just []

335+

336+ Can.Ports ports ->

337+ if Map.member name ports then Nothing else Just (Map.keys ports)

338+

339+ Can.Cmd _ ->

340+ Just []

341+

342+ Can.Sub _ ->

343+ Just []

344+

345+ Can.Fx _ _ ->

346+ Just []

src/Elm/Interface.hsnew file+83

@@ -0,0 +1,83 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Elm.Interface

3+ ( Interfaces

4+ , Interface(..)

5+ , fromModule

6+ , privatize

7+ )

8+ where

10+

11+import Control.Monad (liftM4)

12+import Data.Binary

13+import qualified Data.Map as Map

14+

15+import qualified AST.Expression.Canonical as Canonical

16+import qualified AST.Module.Name as ModuleName

17+import qualified AST.Type as Type

18+import qualified Elm.Name as N

19+

20+

21+

22+-- INTERFACES

23+

24+

25+type Interfaces =

26+ Map.Map ModuleName.Canonical Interface

27+

28+

29+

30+-- INTERFACE

31+

32+

33+data Interface =

34+ Interface

35+ { _types :: Map.Map N.Name Type.Canonical

36+ , _unions :: Map.Map N.Name Canonical.Union

37+ , _aliases :: Map.Map N.Name Canonical.Alias

38+ , _binops :: Map.Map N.Name Canonical.Binop

39+ }

40+

41+

42+

43+-- FROM MODULE

44+

45+

46+fromModule :: Canonical.Module -> Interface

47+fromModule (Canonical.Module _ _ _ _ unions aliases binops _) =

48+ Interface

49+ { _types = error "TODO types"

50+ , _unions = unions

51+ , _aliases = aliases

52+ , _binops = binops

53+ }

54+

55+

56+

57+-- PRIVATIZE

58+

59+

60+privatize :: Interface -> Maybe Interface

61+privatize (Interface _ unions aliases _) =

62+ if Map.null unions && Map.null aliases then

63+ Nothing

64+

65+ else

66+ Just $ Interface

67+ { _types = Map.empty

68+ , _unions = unions

69+ , _aliases = aliases

70+ , _binops = Map.empty

71+ }

72+

73+

74+

75+-- BINARY

76+

77+

78+instance Binary Interface where

79+ get =

80+ liftM4 Interface get get get get

81+

82+ put (Interface a b c d) =

83+ put a >> put b >> put c >> put d