8f032c9 · elk · git.iko.soy

elm-compiler.cabal+1−1

compare with master

unifiedsplit

@@ -61,7 +61,7 @@ Library

61 AST.Type,

62 AST.Variable,

63 Canonicalize,

64− Canonicalize.Declaration,

64+ Canonicalize.Body,

65 Canonicalize.Environment,

66 Canonicalize.Result,

67 Canonicalize.Setup,

src/AST/Expression/General.hs+3

@@ -9,6 +9,7 @@ enrich the AST with more information.

9module AST.Expression.General where

10

11import qualified AST.Literal as Literal

12+import qualified AST.Module.Name as ModuleName

12import qualified AST.Pattern as Pattern

13import qualified AST.Pattern as Pattern

13import qualified AST.Variable as Var

14import qualified AST.Variable as Var

14import qualified Reporting.Annotation as A

15import qualified Reporting.Annotation as A

@@ -53,6 +54,8 @@ data Expr' ann def var typ

53 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]

54 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]

54 | Record [(String, Expr ann def var typ)]

55 | Record [(String, Expr ann def var typ)]

55 -- for type checking and code gen only

56 -- for type checking and code gen only

57+ | Cmd ModuleName.Canonical String

58+ | Sub ModuleName.Canonical String

56 | GLShader String String Literal.GLShaderTipe

59 | GLShader String String Literal.GLShaderTipe

57

60

58

61

src/AST/Expression/Optimized.hs+2

@@ -50,6 +50,8 @@ data Expr

50 | Access Expr String

51 | Update Expr [(String, Expr)]

52 | Record [(String, Expr)]

53+ | Cmd ModuleName.Canonical

54+ | Sub ModuleName.Canonical

53 | GLShader String String Literal.GLShaderTipe

55 | GLShader String String Literal.GLShaderTipe

54 | Crash ModuleName.Canonical R.Region (Maybe Expr)

56 | Crash ModuleName.Canonical R.Region (Maybe Expr)

55

57

src/AST/Type.hs+24−2

@@ -3,8 +3,9 @@ module AST.Type

3 , Canonical(..), Aliased(..)

4 , deepDealias, iteratedDealias, dealias

5 , collectLambdas

6− , tuple

6+ , tuple, cmd, sub

7+ )

7− ) where

8+ where

8

9

9import Control.Arrow (second)

10import Control.Arrow (second)

10import Data.Binary

11import Data.Binary

@@ -51,6 +52,10 @@ data Aliased t

51 deriving (Eq, Ord)

52 deriving (Eq, Ord)

52

53

54

55+

56+-- CONSTRUCT USEFUL TYPES

57+

58+

54tuple :: R.Region -> [Raw] -> Raw

59tuple :: R.Region -> [Raw] -> Raw

55tuple region types =

60tuple region types =

56 let

61 let

@@ -60,6 +65,23 @@ tuple region types =

60 A.A region (RApp (A.A region (RType name)) types)

65 A.A region (RApp (A.A region (RType name)) types)

61

66

62

67

68+cmd :: ModuleName.Canonical -> String -> Canonical

69+cmd =

70+ effect Var.cmd

71+

72+

73+sub :: ModuleName.Canonical -> String -> Canonical

74+sub =

75+ effect Var.sub

76+

77+

78+effect :: Var.Canonical -> ModuleName.Canonical -> String -> Canonical

79+effect effectName moduleName tipe =

80+ Lambda

81+ (App (Type (Var.fromModule moduleName tipe)) [Var "msg"])

82+ (App (Type effectName) [Effects (Set.singleton moduleName), Var "msg"])

83+

84+

63

85

64-- DEALIASING

86-- DEALIASING

65

87

src/AST/Variable.hs+10

@@ -70,6 +70,16 @@ inCore home name =

70 Canonical (Module (ModuleName.inCore home)) name

71

72

73+cmd :: Canonical

74+cmd =

75+ inCore ["Platform"] "Cmd"

76+

77+

78+sub :: Canonical

79+sub =

80+ inCore ["Platform"] "Sub"

81+

82+

73

83

74-- VARIABLE RECOGNIZERS

84-- VARIABLE RECOGNIZERS

75

85

src/Canonicalize.hs+10−5

@@ -7,7 +7,7 @@ import qualified Data.Set as Set

7import qualified Data.Traversable as T

8import qualified Data.Foldable as T

9

10−import AST.Expression.General (Expr'(..), dummyLet)

10+import AST.Expression.General (Expr'(..))

11import Elm.Utils ((|>))

12

13import qualified AST.Declaration as D

@@ -26,11 +26,10 @@ import qualified Reporting.Error.Helpers as ErrorHelp

26import qualified Reporting.Region as Region

27import qualified Reporting.Result as R

28import qualified Reporting.Warning as Warning

29−import qualified Canonicalize.Declaration as Decls

29+import qualified Canonicalize.Body as Body

30import qualified Canonicalize.Environment as Env

31import qualified Canonicalize.Result as Result

32import qualified Canonicalize.Setup as Setup

33−import qualified Canonicalize.Sort as Sort

34import qualified Canonicalize.Type as Canonicalize

33import qualified Canonicalize.Type as Canonicalize

35import qualified Canonicalize.Variable as Canonicalize

34import qualified Canonicalize.Variable as Canonicalize

36

35

@@ -46,7 +45,7 @@ module'

46 -> R.Result Warning.Warning Error.Error Module.Canonical

45 -> R.Result Warning.Warning Error.Error Module.Canonical

47module' canonicalImports interfaces modul =

46module' canonicalImports interfaces modul =

48 let

47 let

49− (Module.Valid docs exports imports decls _) = -- TODO do something with `effects`

48+ (Module.Valid docs exports imports decls effects) =

50 Module.info modul

49 Module.info modul

51

50

52 importDict =

51 importDict =

@@ -76,7 +75,7 @@ module' canonicalImports interfaces modul =

76 A.map (fmap (Docs.centralize canonicalDecls)) docs

75 A.map (fmap (Docs.centralize canonicalDecls)) docs

77

76

78 program =

77 program =

79− Sort.definitions (dummyLet (Decls.toExpr (Module.name modul) canonicalDecls))

78+ Body.flatten (Module.name modul) canonicalDecls effects

80

79

81 fixities =

80 fixities =

82 [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]

81 [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]

@@ -435,6 +434,12 @@ expression env (A.A region validExpr) =

435 <$> pattern env ptrn

434 <$> pattern env ptrn

436 <*> expression (Env.addPattern ptrn env) brnch

435 <*> expression (Env.addPattern ptrn env) brnch

437

436

437+ Cmd moduleName string ->

438+ Result.ok (Cmd moduleName string)

439+

440+ Sub moduleName string ->

441+ Result.ok (Sub moduleName string)

442+

438 GLShader uid src tipe ->

443 GLShader uid src tipe ->

439 Result.ok (GLShader uid src tipe)

444 Result.ok (GLShader uid src tipe)

440

445

src/Canonicalize/Body.hsnew file+146

@@ -0,0 +1,146 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Body (flatten) where

3+

4+import qualified AST.Declaration as D

5+import qualified AST.Expression.General as E

6+import qualified AST.Expression.Canonical as Canonical

7+import qualified AST.Module as Module

8+import qualified AST.Module.Name as ModuleName

9+import qualified AST.Pattern as P

10+import qualified AST.Type as T

11+import qualified AST.Variable as Var

12+import qualified Canonicalize.Sort as Sort

13+import qualified Reporting.Annotation as A

14+import qualified Reporting.Region as R

15+

16+

17+

18+flatten :: ModuleName.Canonical -> [D.Canonical] -> Module.ValidEffects -> Canonical.Expr

19+flatten moduleName decls effects =

20+ let

21+ declDefs =

22+ concatMap (declToDefs moduleName) decls

23+

24+ effectDefs =

25+ effectsToDefs moduleName effects

26+ in

27+ Sort.definitions (E.dummyLet (declDefs ++ effectDefs))

28+

29+

30+

31+-- DECLARATIONS

32+

33+

34+declToDefs :: ModuleName.Canonical -> D.Canonical -> [Canonical.Def]

35+declToDefs moduleName (A.A (region,_) decl) =

36+ let

37+ typeVar =

38+ Var.fromModule moduleName

39+

40+ loc expr =

41+ A.A region expr

42+ in

43+ case decl of

44+ D.Def def ->

45+ [def]

46+

47+ D.Union name tvars constructors ->

48+ let

49+ tagToDef (ctor, tipes) =

50+ let

51+ vars =

52+ take (length tipes) infiniteArgs

53+

54+ tbody =

55+ T.App (T.Type (typeVar name)) (map T.Var tvars)

56+

57+ body =

58+ loc . E.Data ctor $ map (loc . E.localVar) vars

59+ in

60+ definition ctor (buildFunction body vars) region (foldr T.Lambda tbody tipes)

61+ in

62+ map tagToDef constructors

63+

64+ D.Alias name tvars tipe@(T.Record fields Nothing) ->

65+ [ definition name (buildFunction record vars) region (foldr T.Lambda result args) ]

66+ where

67+ result =

68+ T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)

69+

70+ args =

71+ map snd fields

72+

73+ vars =

74+ take (length args) infiniteArgs

75+

76+ record =

77+ loc (E.Record (zip (map fst fields) (map (loc . E.localVar) vars)))

78+

79+ -- Type aliases must be added to an extended equality dictionary,

80+ -- but they do not require any basic constraints.

81+ D.Alias _ _ _ ->

82+ []

83+

84+ -- no constraints are needed for fixity declarations

85+ D.Fixity _ _ _ ->

86+ []

87+

88+

89+infiniteArgs :: [String]

90+infiniteArgs =

91+ map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

92+

93+

94+buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr

95+buildFunction body@(A.A ann _) vars =

96+ foldr

97+ (\pattern expr -> A.A ann (E.Lambda pattern expr))

98+ body

99+ (map (A.A ann . P.Var) vars)

100+

101+

102+definition :: String -> Canonical.Expr -> R.Region -> T.Canonical -> Canonical.Def

103+definition name expr@(A.A ann _) region tipe =

104+ Canonical.Definition

105+ Canonical.dummyFacts

106+ (A.A ann (P.Var name))

107+ expr

108+ (Just (A.A region tipe))

109+

110+

111+

112+-- EFFECTS

113+

114+

115+effectsToDefs :: ModuleName.Canonical -> Module.ValidEffects -> [Canonical.Def]

116+effectsToDefs moduleName effects =

117+ case effects of

118+ Module.ValidNormal ->

119+ []

120+

121+ Module.ValidEffect maybeCmd maybeSub ->

122+ effectsToDefsHelp "command" (E.Cmd moduleName) maybeCmd

123+ ++ effectsToDefsHelp "subscription" (E.Sub moduleName) maybeSub

124+

125+ Module.ValidForeign ->

126+ []

127+

128+

129+effectsToDefsHelp

130+ :: String

131+ -> (String -> Canonical.Expr')

132+ -> Maybe (A.Located String)

133+ -> [Canonical.Def]

134+effectsToDefsHelp name toExpr' maybeEffect =

135+ case maybeEffect of

136+ Nothing ->

137+ []

138+

139+ Just (A.A region typeName) ->

140+ [ Canonical.Definition

141+ Canonical.dummyFacts

142+ (A.A region (P.Var name))

143+ (A.A region (toExpr' typeName))

144+ Nothing

145+ ]

146+

src/Canonicalize/Declaration.hsdeleted−87

@@ -1,87 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize.Declaration (toExpr) where

3−

4−import qualified AST.Declaration as D

5−import qualified AST.Expression.General as E

6−import qualified AST.Expression.Canonical as Canonical

7−import qualified AST.Module.Name as ModuleName

8−import qualified AST.Pattern as P

9−import qualified AST.Type as T

10−import qualified AST.Variable as Var

11−import qualified Reporting.Annotation as A

12−import qualified Reporting.Region as R

13−

14−

15−toExpr :: ModuleName.Canonical -> [D.Canonical] -> [Canonical.Def]

16−toExpr moduleName decls =

17− concatMap (toDefs moduleName) decls

18−

19−

20−toDefs :: ModuleName.Canonical -> D.Canonical -> [Canonical.Def]

21−toDefs moduleName (A.A (region,_) decl) =

22− let

23− typeVar =

24− Var.fromModule moduleName

25−

26− loc expr =

27− A.A region expr

28− in

29− case decl of

30− D.Def def ->

31− [def]

32−

33− D.Union name tvars constructors ->

34− concatMap toDefs' constructors

35− where

36− toDefs' (ctor, tipes) =

37− let vars = take (length tipes) infiniteArgs

38− tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)

39− body = loc . E.Data ctor $ map (loc . E.localVar) vars

40− in

41− [ definition ctor (buildFunction body vars) region (foldr T.Lambda tbody tipes) ]

42−

43− D.Alias name tvars tipe@(T.Record fields Nothing) ->

44− [ definition name (buildFunction record vars) region (foldr T.Lambda result args) ]

45− where

46− result =

47− T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)

48−

49− args =

50− map snd fields

51−

52− vars =

53− take (length args) infiniteArgs

54−

55− record =

56− loc (E.Record (zip (map fst fields) (map (loc . E.localVar) vars)))

57−

58− -- Type aliases must be added to an extended equality dictionary,

59− -- but they do not require any basic constraints.

60− D.Alias _ _ _ ->

61− []

62−

63− -- no constraints are needed for fixity declarations

64− D.Fixity _ _ _ ->

65− []

66−

67−

68−infiniteArgs :: [String]

69−infiniteArgs =

70− map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

71−

72−

73−buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr

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

75− foldr

76− (\pattern expr -> A.A ann (E.Lambda pattern expr))

77− body

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

79−

80−

81−definition :: String -> Canonical.Expr -> R.Region -> T.Canonical -> Canonical.Def

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

83− Canonical.Definition

84− Canonical.dummyFacts

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

86− expr

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

src/Canonicalize/Setup.hs+28−10

@@ -32,7 +32,7 @@ environment

32 -> Result.ResultErr Env.Environment

33environment importDict interfaces (Module.Module name _ info) =

34 let

35− (Module.Valid _ _ (defaults, imports) decls _) = -- TODO add foreign effects as patches?

35+ (Module.Valid _ _ (defaults, imports) decls effects) =

36 info

37

38 allImports =

@@ -44,11 +44,14 @@ environment importDict interfaces (Module.Module name _ info) =

44 (typeAliasNodes, declPatches) =

45 declarationsToPatches name decls

46

47+ effectPatches =

48+ effectsToPatches name effects

49+

47 createEnv (moduleNamePairs, patchLists) =

50 createEnv (moduleNamePairs, patchLists) =

48 Env.fromPatches

51 Env.fromPatches

49 name

52 name

50 (Map.fromList (Maybe.catMaybes moduleNamePairs))

53 (Map.fromList (Maybe.catMaybes moduleNamePairs))

51− (concat (Env.builtinPatches : declPatches : patchLists))

54+ (concat (Env.builtinPatches : declPatches : effectPatches : patchLists))

52 in

55 in

53 (createEnv <$> importIngredients)

56 (createEnv <$> importIngredients)

54 `Result.andThen` addTypeAliases name typeAliasNodes

57 `Result.andThen` addTypeAliases name typeAliasNodes

@@ -307,10 +310,7 @@ addTypeAlias moduleName scc env =

307-- DECLARATIONS TO PATCHES

310-- DECLARATIONS TO PATCHES

308

311

309

312

310−declarationsToPatches

313+declarationsToPatches :: ModuleName.Canonical -> [D.Valid] -> ([Node], [Env.Patch])

311− :: ModuleName.Canonical

312− -> [D.Valid]

313− -> ([Node], [Env.Patch])

314declarationsToPatches moduleName decls =

315 let

316 (maybeNodes, patchLists) =

@@ -324,10 +324,7 @@ declarationsToPatches moduleName decls =

324-- _patterns are fully namespaced (Var.Module ...)

325-- _values that are defined as top-level declarations are (Var.TopLevel ...)

326-- all other _values are local (Var.Local)

327−declToPatches

328− :: ModuleName.Canonical

327+declToPatches :: ModuleName.Canonical -> D.Valid -> (Maybe Node, [Env.Patch])

329− -> D.Valid

330− -> (Maybe Node, [Env.Patch])

331declToPatches moduleName (A.A (region,_) decl) =

328declToPatches moduleName (A.A (region,_) decl) =

332 let

329 let

333 topLevel mkPatch x =

330 topLevel mkPatch x =

@@ -370,6 +367,27 @@ declToPatches moduleName (A.A (region,_) decl) =

370

367

371

368

372

369

370+-- EFFECTS TO PATCHES

371+

372+

373+effectsToPatches :: ModuleName.Canonical -> Module.ValidEffects -> [Env.Patch]

374+effectsToPatches moduleName effects =

375+ case effects of

376+ Module.ValidNormal ->

377+ []

378+

379+ Module.ValidEffect maybeCmd maybeSub ->

380+ map (\name -> Env.Value name (Var.topLevel moduleName name)) $

381+ Maybe.catMaybes

382+ [ fmap (const "command") maybeCmd

383+ , fmap (const "subscription") maybeSub

384+ ]

385+

386+ Module.ValidForeign ->

387+ []

388+

389+

390+

373-- RESTRICT VISIBLE API OF INTERFACES

391-- RESTRICT VISIBLE API OF INTERFACES

374

392

375

393

src/Canonicalize/Sort.hs+6

@@ -96,6 +96,12 @@ reorder (A.A ann expression) =

96 Record

97 <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

98

99+ Cmd _ _ ->

100+ return expression

101+

102+ Sub _ _ ->

103+ return expression

104+

99 GLShader _ _ _ ->

105 GLShader _ _ _ ->

100 return expression

106 return expression

101

107

src/Generate/JavaScript/BuiltIn.hs+13

@@ -69,6 +69,19 @@ cmp left right =

69

70

71

72+-- EFFECTS

73+

74+

75+cmd :: ModuleName.Canonical -> JS.Expression ()

76+cmd effectName =

77+ utils "cmd" [ JS.StringLit () (ModuleName.canonicalToString effectName) ]

78+

79+

80+sub :: ModuleName.Canonical -> JS.Expression ()

81+sub effectName =

82+ utils "sub" [ JS.StringLit () (ModuleName.canonicalToString effectName) ]

83+

84+

72-- CRASH

85-- CRASH

73

86

74

87

src/Generate/JavaScript/Expression.hs+6

@@ -197,6 +197,12 @@ generateCode expr =

197 do jsDataExpr <- generateJsExpr dataExpr

198 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))

199

200+ Cmd moduleName ->

201+ jsExpr $ BuiltIn.cmd moduleName

202+

203+ Sub moduleName ->

204+ jsExpr $ BuiltIn.sub moduleName

205+

200 GLShader _uid src _tipe ->

206 GLShader _uid src _tipe ->

201 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]

207 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]

202

208

src/Nitpick/PatternMatches.hs+6

@@ -183,6 +183,12 @@ checkExpression tagDict (A.A region expression) =

183 E.Record fields ->

184 F.traverse_ (go . snd) fields

185

186+ E.Cmd _ _ ->

187+ Result.ok ()

188+

189+ E.Sub _ _ ->

190+ Result.ok ()

191+

186 E.GLShader _ _ _ ->

192 E.GLShader _ _ _ ->

187 Result.ok ()

193 Result.ok ()

188

194

src/Optimize.hs+6

@@ -301,6 +301,12 @@ optimizeExpr context annExpr@(A.A region expression) =

301 Opt.Record

302 <$> T.traverse (mapSnd justConvert) fields

303

304+ Expr.Cmd moduleName _ ->

305+ pure (Opt.Cmd moduleName)

306+

307+ Expr.Sub moduleName _ ->

308+ pure (Opt.Sub moduleName)

309+

304 Expr.GLShader uid src gltipe ->

310 Expr.GLShader uid src gltipe ->

305 pure (Opt.GLShader uid src gltipe)

311 pure (Opt.GLShader uid src gltipe)

306

312

src/Optimize/Inline.hs+17

@@ -49,8 +49,11 @@ processSubs (Subs subs defs) (name, (n, expr)) =

49 (Map.insert name (Opt.Var (Var.local uniqueName)) subs)

50 ((uniqueName, expr) : defs)

51

52+

53+

52-- HELPERS

54-- HELPERS

53

55

56+

54deleteBatch :: [String] -> Map.Map String a -> Map.Map String a

57deleteBatch :: [String] -> Map.Map String a -> Map.Map String a

55deleteBatch names dict =

58deleteBatch names dict =

56 List.foldl' (flip Map.delete) dict names

59 List.foldl' (flip Map.delete) dict names

@@ -66,8 +69,10 @@ getDefName def =

66 name

69 name

67

70

68

71

72+

69-- COUNT VARIABLE APPEARANCES

73-- COUNT VARIABLE APPEARANCES

70

74

75+

71count :: Opt.Expr -> Map.Map String Int

76count :: Opt.Expr -> Map.Map String Int

72count expression =

77count expression =

73 let

78 let

@@ -164,6 +169,12 @@ count expression =

164 Record fields ->

169 Record fields ->

165 countMany (map snd fields)

170 countMany (map snd fields)

166

171

172+ Cmd _ ->

173+ Map.empty

174+

175+ Sub _ ->

176+ Map.empty

177+

167 GLShader _ _ _ ->

178 GLShader _ _ _ ->

168 Map.empty

179 Map.empty

169

180

@@ -263,6 +274,12 @@ replace substitutions expression =

263 Record fields ->

274 Record fields ->

264 Record (map (second go) fields)

275 Record (map (second go) fields)

265

276

277+ Cmd _ ->

278+ expression

279+

280+ Sub _ ->

281+ expression

282+

266 GLShader _ _ _ ->

283 GLShader _ _ _ ->

267 expression

284 expression

268

285

src/Type/Constrain/Expression.hs+10

@@ -36,6 +36,16 @@ constrain env annotatedExpr@(A.A region expression) tipe =

36 E.Literal lit ->

37 Literal.constrain env region lit tipe

38

39+ E.Cmd moduleName typeName ->

40+ do (vars, cmd) <-

41+ Env.instantiateType env (ST.cmd moduleName typeName) Map.empty

42+ return $ ex vars (CEqual (error "TODO - Cmd") region cmd tipe)

43+

44+ E.Sub moduleName typeName ->

45+ do (vars, sub) <-

46+ Env.instantiateType env (ST.sub moduleName typeName) Map.empty

47+ return $ ex vars (CEqual (error "TODO - Sub") region sub tipe)

48+

39 E.GLShader _uid _src gltipe ->

49 E.GLShader _uid _src gltipe ->

40 exists $ \attr ->

50 exists $ \attr ->

41 exists $ \unif ->

51 exists $ \unif ->

src/Validate.hs+6

@@ -401,6 +401,12 @@ expression (A.A ann sourceExpression) =

401 <$> definitions defs

402 <*> expression body

403

404+ Cmd moduleName typeName ->

405+ return (Cmd moduleName typeName)

406+

407+ Sub moduleName typeName ->

408+ return (Sub moduleName typeName)

409+

404 GLShader uid src gltipe ->

410 GLShader uid src gltipe ->

405 return (GLShader uid src gltipe)

411 return (GLShader uid src gltipe)

406

412