c215b4f · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Get canonicalization of modules compiling

c215b4fEvan Czaplicki9 years ago

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

compare with master

unifiedsplit

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

17 , Union(..)

18 , Binop(..)

19 , Effects(..)

20− , Port(..)

20+ , Exports(..)

21+ , Export(..)

21 , Docs(..)

22 , Docs(..)

22 )

23 )

23 where

24 where

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

26import Control.Monad (liftM2, liftM3)

27import Control.Monad (liftM2, liftM3)

27import Data.Binary

28import Data.Binary

29+import qualified Data.ByteString as B

28import qualified Data.Map as Map

30import qualified Data.Map as Map

29import Data.Text (Text)

31import Data.Text (Text)

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

35import qualified Elm.Name as N

37import qualified Elm.Name as N

36import Elm.Name (Name)

38import Elm.Name (Name)

37import qualified Reporting.Annotation as A

39import qualified Reporting.Annotation as A

38−import qualified Reporting.Region as R

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

142 Module

143 Module

143 { _name :: ModuleName.Canonical

144 { _name :: ModuleName.Canonical

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

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

145− , _imports :: [N.Name]

146+ , _exports :: Exports

146 , _decls :: Decls

147 , _decls :: Decls

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

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

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

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

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

151 }

152 }

152

153

154

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

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

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

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

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

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

157

158

158data Effects

159data Effects

159 = NoEffects

160 = NoEffects

160− | Ports [Port]

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

161− | Cmd

162+ | Cmd N.Name

162− | Sub

163+ | Sub N.Name

163− | Fx

164+ | Fx N.Name N.Name

164

165

166

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

167

179

168

180

169

181

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

172

184

173data Docs =

185data Docs =

174 Docs

186 Docs

175− { _overview :: Text

187+ { _overview :: B.ByteString

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

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

177 }

189 }

178

190

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

182

194

183

195

184instance Binary Alias where

196instance Binary Alias where

185− get = liftM2 Alias get get

197+ get = liftM3 Alias get get get

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

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

187

199

188

200

189instance Binary Union where

201instance 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

91data Effects

92 = NoEffects

93 | Ports [Port]

94− | Cmd (A.Located Text)

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

95− | Sub (A.Located Text)

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

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

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

99data 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 =

90importToEnv :: 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) =

92 let

93 patterns =

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

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

160

161

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

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

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

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

165

166

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

277

278

279verifyExposed :: 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) =

281 case exposed of

282 Src.Operator name ->

283 verifyValue moduleName region name interface

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

301

302

303verifyValue :: 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 _ _ _) =

305 case Map.lookup name types of

306 Nothing ->

307 throwExposingNotFound moduleName region name interface

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

321

322

323throwExposingNotFound :: 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 _) =

325 let

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

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

src/Canonicalize/Module.hs+176−10

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

10import qualified Data.Set as Set

12import qualified AST.Expression.Canonical as Can

13+import qualified AST.Expression.Source as Src

13import qualified AST.Expression.Valid as Valid

14import qualified AST.Expression.Valid as Valid

14import qualified AST.Module.Name as ModuleName

15import qualified AST.Module.Name as ModuleName

15import qualified AST.Type as Type

16import qualified AST.Type as Type

16import qualified Canonicalize.Environment as Env

17import qualified Canonicalize.Environment as Env

18+import qualified Canonicalize.Environment.Dups as Dups

17import qualified Canonicalize.Expression as Expr

19import qualified Canonicalize.Expression as Expr

18import qualified Canonicalize.Pattern as Pattern

20import qualified Canonicalize.Pattern as Pattern

19import qualified Canonicalize.Type as Type

21import qualified Canonicalize.Type as Type

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

47 -> Result Can.Module

49 -> Result Can.Module

48canonicalize pkg importDict interfaces module_ =

50canonicalize pkg importDict interfaces module_ =

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

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

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

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

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

53+ (cdecls, cunions, caliases) <-

52− <$> error "TODO docs"

54+ (,,)

53− <*> error "TODO imports"

54− <*> canonicalizeDecls env decls

55+ <$> canonicalizeDecls env decls

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

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

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

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

58+

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

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

58− <*> error "TODO effects"

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

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

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

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

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

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

67 do ctipe <- Type.canonicalize env tipe

88 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

100

101

102

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

178

209

179 Function _ _ _ _ ->

210 Function _ _ _ _ ->

180 Nothing

211 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