git.iko.soy/elk
on master help sign in
Reformulate AST for changes in validation / canonicalization

Centralize data structures in the Source, Valid, and Canonical categories. This is in contrast to organizing by Module, Effects, Declarations, etc. This structure makes it easier to get a quick overview of each phase. I think it is clearer. It also encourages being explicit in each phase, rather than finding clever data structures that can be shared by adding type variables that get upgraded over time.

commit959c23d930de5e43ac4fba4ac8b915714414747c authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 25 Oct 2017, 19:00 (9 years ago) parentda9e6b7
11 files changed+419−914
compare with master
unifiedsplit
src/AST/Binop.hs+55 src/AST/Declaration.hs−166 src/AST/Effects.hs−101 src/AST/Exposing.hs−80 src/AST/Expression/Canonical.hs+93−99 src/AST/Expression/Source.hs+108−52 src/AST/Expression/Valid.hs+100 src/AST/Helpers.hs−65 src/AST/Module.hs−245 src/AST/Type.hs+58−61 src/AST/Variable.hs+5−45
src/AST/Binop.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Binop
3+ ( Precedence
4+ , Associativity(..)
5+ )
6+ where
7+
8+
9+import Prelude hiding (Either(..))
10+import Control.Monad (liftM)
11+import Data.Binary
12+
13+
14+
15+-- BINOP STUFF
16+
17+
18+newtype Precedence = Precedence Int
19+
20+
21+data Associativity
22+ = Left
23+ | Non
24+ | Right
25+ deriving (Eq)
26+
27+
28+
29+-- BINARY
30+
31+
32+instance Binary Precedence where
33+ get =
34+ liftM Precedence get
35+
36+ put (Precedence n) =
37+ put n
38+
39+
40+instance Binary Associativity where
41+ get =
42+ do n <- getWord8
43+ return $
44+ case n of
45+ 0 -> Left
46+ 1 -> Non
47+ 2 -> Right
48+ _ -> error "Error reading valid associativity from serialized string"
49+
50+ put assoc =
51+ putWord8 $
52+ case assoc of
53+ Left -> 0
54+ Non -> 1
55+ Right -> 2
src/AST/Declaration.hsdeleted−166
@@ -1,166 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module AST.Declaration where
4−
5−import Prelude hiding (Either(..))
6−import Control.Monad (liftM3)
7−import Data.Binary
8−import Data.Text (Text)
9−
10−import qualified AST.Expression.Canonical as Canonical
11−import qualified AST.Expression.Source as Src
12−import qualified AST.Type as Type
13−import qualified Reporting.Annotation as A
14−
15−
16−
17−-- SOURCE DECLARATIONS
18−
19−
20−type Source =
21− CommentOr (A.Located Raw)
22−
23−
24−data CommentOr a
25− = Comment (A.Located Text)
26− | Whatever a
27−
28−
29−data Raw
30− = Def Src.RawDef
31− | Union (Union Type.Raw)
32− | Alias (Alias Type.Raw)
33− | Fixity Infix
34− | Port Text Type.Raw
35−
36−
37−
38−-- STRUCTURED DECLARATIONS
39−
40−
41−data Decls def tipe =
42− Decls
43− { _defs :: [A.Commented def]
44− , _unions :: [A.Commented (Union tipe)]
45− , _aliases :: [A.Commented (Alias tipe)]
46− , _infixes :: [Infix]
47− }
48−
49−
50−type Valid =
51− Decls Src.ValidDef Type.Raw
52−
53−
54−type Canonical =
55− Decls Canonical.Def Type.Canonical
56−
57−
58−addDef :: A.Commented d -> Decls d t -> Decls d t
59−addDef def decls =
60− decls { _defs = def : _defs decls }
61−
62−
63−addUnion :: A.Commented (Union t) -> Decls d t -> Decls d t
64−addUnion union decls =
65− decls { _unions = union : _unions decls }
66−
67−
68−addAlias :: A.Commented (Alias t) -> Decls d t -> Decls d t
69−addAlias alias decls =
70− decls { _aliases = alias : _aliases decls }
71−
72−
73−addInfix :: Infix -> Decls d t -> Decls d t
74−addInfix fixity decls =
75− decls { _infixes = fixity : _infixes decls }
76−
77−
78−
79−-- TYPE DECLARATIONS
80−
81−
82−data Type body =
83− Type
84− { _name :: Text
85− , _args :: [Text]
86− , _body :: body
87− }
88−
89−
90−type Union tipe =
91− Type [(Text, [tipe])]
92−
93−
94−type Alias tipe =
95− Type tipe
96−
97−
98−
99−-- INFIX STUFF
100−
101−
102−data Infix =
103− Infix
104− { _op :: Text
105− , _associativity :: Assoc
106− , _precedence :: Int
107− }
108−
109−
110−data Assoc = Left | Non | Right
111− deriving (Eq)
112−
113−
114−defaultAssociativity :: Assoc
115−defaultAssociativity =
116− Left
117−
118−
119−defaultPrecedence :: Int
120−defaultPrecedence =
121− 9
122−
123−
124−assocToText :: Assoc -> Text
125−assocToText assoc =
126− case assoc of
127− Left ->
128− "left"
129−
130− Non ->
131− "non"
132−
133− Right ->
134− "right"
135−
136−
137−
138−-- BINARY
139−
140−
141−instance Binary Infix where
142− get =
143− liftM3 Infix get get get
144−
145− put (Infix op assoc prec) =
146− do put op
147− put assoc
148− put prec
149−
150−
151−instance Binary Assoc where
152− get =
153− do n <- getWord8
154− return $
155− case n of
156− 0 -> Left
157− 1 -> Non
158− 2 -> Right
159− _ -> error "Error reading valid associativity from serialized string"
160−
161− put assoc =
162− putWord8 $
163− case assoc of
164− Left -> 0
165− Non -> 1
166− Right -> 2
src/AST/Effects.hsdeleted−101
@@ -1,101 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module AST.Effects
3− ( Effects(..), Raw, Canonical
4− , Info(..)
5− , RawManagerType(..), ManagerType(..)
6− , PortRaw(..), PortCanonical(..), Kind(..)
7− )
8− where
9−
10−import Data.Binary
11−import Data.Text (Text)
12−
13−import qualified AST.Type as Type
14−import qualified Elm.Package as Pkg
15−import qualified Reporting.Annotation as A
16−import qualified Reporting.Region as R
17−
18−
19−
20−-- EFFECTS
21−
22−
23−data Effects pkg ports
24− = None
25− | Manager pkg Info
26− | Port ports
27−
28−
29−type Raw =
30− Effects () [A.Commented PortRaw]
31−
32−
33−type Canonical =
34− Effects Pkg.Name [A.Commented PortCanonical]
35−
36−
37−
38−-- EFFECT MANAGERS
39−
40−
41−data Info =
42− Info
43− { _tag :: R.Region
44− , _init :: R.Region
45− , _onEffects :: R.Region
46− , _onSelfMsg :: R.Region
47− , _managerType :: RawManagerType
48− }
49−
50−
51−data RawManagerType
52− = CmdManager (A.Located Text)
53− | SubManager (A.Located Text)
54− | FxManager (A.Located Text) (A.Located Text)
55−
56−
57−data ManagerType = Cmds | Subs | Both
58−
59−
60−
61−-- FOREIGN EFFECTS
62−
63−
64−data PortRaw =
65− PortRaw
66− { _rawName :: Text
67− , _rawType :: Type.Raw
68− }
69−
70−
71−data PortCanonical =
72− PortCanonical
73− { _name :: Text
74− , _kind :: Kind
75− , _type :: Type.Canonical
76− }
77−
78−
79−data Kind
80− = Outgoing Type.Canonical
81− | Incoming Type.Canonical
82−
83−
84−
85−-- BINARY
86−
87−
88−instance Binary ManagerType where
89− put managerType =
90− case managerType of
91− Cmds -> putWord8 0
92− Subs -> putWord8 1
93− Both -> putWord8 2
94−
95− get =
96− do word <- getWord8
97− case word of
98− 0 -> pure Cmds
99− 1 -> pure Subs
100− 2 -> pure Both
101− _ -> error "problem getting Effects.ManagerType binary"
src/AST/Exposing.hsdeleted−80
@@ -1,80 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module AST.Exposing
3− ( Canonical(..)
4− , nothing
5− , Raw
6− , Exposing(..)
7− , closed
8− , Entry(..)
9− , getName
10− )
11− where
12−
13−import Data.Binary (Binary, get, put)
14−import Data.Text (Text)
15−
16−import qualified Reporting.Annotation as A
17−
18−
19−
20−-- CANONICAL
21−
22−
23−data Canonical =
24− Canonical
25− { _values :: ![Text]
26− , _aliases :: ![Text]
27− , _unions :: ![(Text, [Text])]
28− }
29−
30−
31−nothing :: Canonical
32−nothing =
33− Canonical [] [] []
34−
35−
36−
37−-- RAW
38−
39−
40−type Raw = Exposing Entry
41−
42−
43−data Exposing a
44− = Open
45− | Explicit ![A.Located a]
46−
47−
48−closed :: Exposing a
49−closed =
50− Explicit []
51−
52−
53−data Entry
54− = Lower !Text
55− | Upper !Text (Maybe (Exposing Text))
56−
57−
58−getName :: Entry -> Text
59−getName entry =
60− case entry of
61− Lower name ->
62− name
63−
64− Upper name _ ->
65− name
66−
67−
68−
69−-- BINARY
70−
71−
72−instance Binary Canonical where
73− get =
74− Canonical <$> get <*> get <*> get
75−
76− put (Canonical values aliases unions) =
77− do put values
78− put aliases
79− put unions
80−
src/AST/Expression/Canonical.hs+93−99
@@ -1,27 +1,35 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module AST.Expression.Canonical
4− ( Expr, Expr'(..)
5− , Main(..)
4+ ( Expr
5+ , Expr_(..)
66 , Def(..)
7− , SortedDefs(..), toSortedDefs
8− , localVar
9− , collectApps, collectFields, collectLambdas
7+ , Decl(..)
8+ , Module(..)
9+ , Alias(..)
10+ , Union(..)
11+ , Binop(..)
12+ , Effects(..)
13+ , Port(..)
14+ , Docs(..)
1015 )
1116 where
1217
1318
14−import Data.Monoid ((<>))
19+import Control.Monad (liftM2, liftM3)
20+import Data.Binary
21+import qualified Data.Graph as Graph
22+import qualified Data.Map as Map
1523import Data.Text (Text)
16−import qualified Data.Text.Lazy as LText
17−import qualified Data.Text.Lazy.Builder as B
1824
19−import qualified AST.Effects as Effects
25+import qualified AST.Binop as Binop
2026import qualified AST.Literal as Literal
2127import qualified AST.Module.Name as ModuleName
2228import qualified AST.Pattern as Ptrn
2329import qualified AST.Type as Type
2430import qualified AST.Variable as Var
31+import qualified Elm.Name as N
32+import Elm.Name (Name)
2533import qualified Reporting.Annotation as A
2634import qualified Reporting.Region as R
2735
@@ -31,36 +39,31 @@ import qualified Reporting.Region as R
3139
3240
3341type Expr =
34− A.Annotated R.Region Expr'
35−
36−
37−data Expr'
38− = Literal Literal.Literal
39− | Var Var.Canonical
40− | List [Expr]
41− | Binop Var.Canonical Expr Expr
42− | Lambda Ptrn.Canonical Expr
43− | App Expr Expr
44− | If [(Expr, Expr)] Expr
45− | Let [Def] Expr
46− | Case Expr [(Ptrn.Canonical, Expr)]
47− | Ctor Var.Canonical [Expr]
48− | Access Expr Text
49− | Update Expr [(Text, Expr)]
50− | Record [(Text, Expr)]
51− -- for type checking and code gen only
52− | Cmd ModuleName.Canonical Effects.ManagerType
53− | Sub ModuleName.Canonical Effects.ManagerType
54− | OutgoingPort Text Type.Canonical
55− | IncomingPort Text Type.Canonical
56− | Program Main Expr
57− | SaveEnv ModuleName.Canonical Effects.Canonical
58− | GLShader Text Text Literal.Shader
59−
60−
61−data Main
62− = Static
63− | Dynamic Type.Canonical
42+ A.Annotated R.Region Expr_
43+
44+
45+data Expr_
46+ = VarLocal Name
47+ | VarTopLevel ModuleName.Canonical Name
48+ | VarKernel Name Name
49+ | VarForeign ModuleName.Canonical Name
50+ | VarOperator ModuleName.Canonical Name Name
51+ | Literal Literal.Literal
52+ | List [Expr]
53+ | Binop Name ModuleName.Canonical Name Expr Expr
54+ | Lambda Ptrn.Canonical Expr
55+ | Call Expr [Expr]
56+ | If [(Expr, Expr)] Expr
57+ | Let [Graph.SCC Def] Expr
58+ | Case Expr [(Ptrn.Canonical, Expr)]
59+ | CtorAccess Expr Int
60+ | Accessor Name
61+ | Access Expr Name
62+ | Update Expr [(Name, Expr)]
63+ | Record [(Name, Expr)]
64+ | Unit
65+ | Tuple Expr Expr [Expr]
66+ | GLShader Name Name Literal.Shader
6467
6568
6669
@@ -69,93 +72,84 @@ data Main
6972
7073data Def =
7174 Def
72− { _region :: R.Region
73− , _pattern :: Ptrn.Canonical
74− , _body :: Expr
75− , _type :: Maybe (A.Located Type.Canonical)
75+ { _let_name :: Text
76+ , _let_args :: [A.Located Ptrn.Canonical]
77+ , _let_body :: Expr
78+ , _let_type :: Maybe (A.Located Type.Canonical)
7679 }
7780
7881
7982
80−-- SORTED DEFS
83+-- DECLARATIONS
8184
8285
83−data SortedDefs
84− = NoMain [Def]
85− | YesMain [Def] Def [Def]
86−
87−
88−toSortedDefs :: Expr -> SortedDefs
89−toSortedDefs (A.A _ expr) =
90− case expr of
91− Let defs body ->
92− foldr defCons (toSortedDefs body) defs
86+data Decl =
87+ Decl
88+ { _top_name :: Text
89+ , _top_args :: [A.Located Ptrn.Canonical]
90+ , _top_body :: Expr
91+ , _top_type :: Maybe (A.Located Type.Canonical)
92+ , _top_deps :: [Var.Global]
93+ }
9394
94− _ ->
95− NoMain []
9695
9796
98−defCons :: Def -> SortedDefs -> SortedDefs
99−defCons def@(Def _ (A.A _ pattern) _ _) sortedDefs =
100− case (pattern, sortedDefs) of
101− (Ptrn.Var "main", NoMain defs) ->
102− YesMain [] def defs
97+-- MODULES
10398
104− (_, NoMain defs) ->
105− NoMain (def : defs)
10699
107− (_, YesMain defs main rest) ->
108− YesMain (def : defs) main rest
100+data Module phase =
101+ Module
102+ { _name :: ModuleName.Canonical
103+ , _docs :: A.Located (Maybe Docs)
104+ , _imports :: [N.Name]
105+ , _decls :: [Graph.SCC Decl]
106+ , _unions :: Map.Map N.Name Union
107+ , _aliases :: Map.Map N.Name Alias
108+ , _binops :: Map.Map N.Name Binop
109+ , _effects :: Effects
110+ }
109111
110112
113+data Alias = Alias [N.Name] Type.Canonical
114+data Union = Union [N.Name] [(N.Name, [Type.Canonical])]
115+data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name
111116
112−-- HELPERS
117+data Effects
118+ = NoEffects
119+ | Ports [Port]
120+ | Cmd
121+ | Sub
122+ | Fx
113123
114124
115−localVar :: Text -> Expr'
116−localVar x =
117− Var (Var.Canonical Var.Local x)
125+data Port = Port R.Region N.Name Type.Canonical
118126
119127
120−-- COLLECTORS
121128
129+-- DOCS
122130
123−collectApps :: Expr -> [Expr]
124−collectApps annExpr@(A.A _ expr) =
125− case expr of
126− App a b ->
127− collectApps a ++ [b]
128131
129− _ ->
130− [annExpr]
132+data Docs =
133+ Docs
134+ { _overview :: Text
135+ , _comments :: Map.Map N.Name Text
136+ }
131137
132138
133−collectFields :: Expr -> Maybe Text
134−collectFields expr =
135− fmap (LText.toStrict . B.toLazyText) (collectFieldsHelp expr mempty)
136139
140+-- BINARY
137141
138−collectFieldsHelp :: Expr -> B.Builder -> Maybe B.Builder
139−collectFieldsHelp (A.A _ expr) builder =
140− case expr of
141− Var var ->
142− Just (B.fromText (Var.toText var) <> builder)
143142
144− Access record field ->
145− collectFieldsHelp record ("." <> B.fromText field <> builder)
143+instance Binary Alias where
144+ get = liftM2 Alias get get
145+ put (Alias a b) = put a >> put b
146146
147− _ ->
148− Nothing
149147
148+instance Binary Union where
149+ get = liftM2 Union get get
150+ put (Union a b) = put a >> put b
150151
151−collectLambdas :: Expr -> ([Ptrn.Canonical], Expr)
152−collectLambdas lexpr@(A.A _ expr) =
153− case expr of
154− Lambda pattern body ->
155− let
156− (ps, body') = collectLambdas body
157− in
158− (pattern : ps, body')
159152
160− _ ->
161− ([], lexpr)
153+instance Binary Binop where
154+ get = liftM3 Binop_ get get get
155+ put (Binop_ a b c) = put a >> put b >> put c
src/AST/Expression/Source.hs+108−52
@@ -1,18 +1,29 @@
11{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
23module AST.Expression.Source
3− ( RawExpr, RawExpr', RawDef, RawDef'(..)
4− , ValidExpr, ValidExpr', ValidDef(..)
5− , Expr, Expr'(..)
6− , zero, collectLambdas
4+ ( Expr, Expr_(..)
5+ , Decl, Decl_(..)
6+ , Def(..)
7+ , Module(..)
8+ , Import(..)
9+ , Effects(..)
10+ , Manager(..)
11+ , defaultModule
12+ , Exposing(..)
13+ , Exposed(..)
14+ , Privacy(..)
715 )
816 where
917
1018
19+import qualified Data.ByteString as B
1120import Data.Text (Text)
1221
22+import qualified AST.Binop as Binop
1323import qualified AST.Literal as Literal
1424import qualified AST.Pattern as Ptrn
1525import qualified AST.Type as Type
26+import qualified Elm.Name as N
1627import qualified Reporting.Annotation as A
1728import qualified Reporting.Region as R
1829
@@ -21,75 +32,120 @@ import qualified Reporting.Region as R
2132-- EXPRESSIONS
2233
2334
24−type Expr def =
25− A.Located (Expr' def)
35+type Expr = A.Located Expr_
2636
2737
28−data Expr' def
29− = Literal Literal.Literal
30− | Var (Maybe Text) Text
31− | List [Expr def]
32− | Op Text
33− | Binop [(Expr def, A.Located Text)] (Expr def)
34− | Lambda Ptrn.Raw (Expr def)
35− | App (Expr def) (Expr def)
36− | If [(Expr def, Expr def)] (Expr def)
37− | Let [def] (Expr def)
38− | Case (Expr def) [(Ptrn.Raw, Expr def)]
39− | Accessor Text
40− | Access (Expr def) Text
41− | Update (A.Located Text) [(A.Located Text, Expr def)]
42− | Record [(A.Located Text, Expr def)]
43− | Unit
44− | Tuple (Expr def) (Expr def) [Expr def]
45− | GLShader Text Text Literal.Shader
38+data Expr_
39+ = Literal Literal.Literal
40+ | Var (Maybe N.Name) N.Name
41+ | List [Expr]
42+ | Op N.Name
43+ | Negate Expr
44+ | Binops [(Expr, A.Located N.Name)] Expr
45+ | Lambda Ptrn.Raw Expr
46+ | Call Expr [Expr]
47+ | If [(Expr, Expr)] Expr
48+ | Let [A.Located Def] Expr
49+ | Case Expr [(Ptrn.Raw, Expr)]
50+ | Accessor N.Name
51+ | Access Expr N.Name
52+ | Update (A.Located N.Name) [(A.Located N.Name, Expr)]
53+ | Record [(A.Located N.Name, Expr)]
54+ | Unit
55+ | Tuple Expr Expr [Expr]
56+ | GLShader Text Text Literal.Shader
4657
4758
48−type RawExpr = Expr RawDef
4959
50−type RawExpr' = Expr' RawDef
60+-- DEFINITIONS
5161
52−type ValidExpr = Expr ValidDef
5362
54−type ValidExpr' = Expr' ValidDef
63+data Def
64+ = Annotate Text Type.Raw
65+ | Define Text [Ptrn.Raw] Expr
66+ | Destruct Ptrn.Raw Expr
5567
5668
5769
58−-- DEFINITIONS
70+-- DECLARATIONS
71+
72+
73+type Decl = A.Located Decl_
74+
75+
76+data Decl_
77+ = Union (A.Located N.Name) [A.Located N.Name] [(A.Located Text, [Type.Raw])]
78+ | Alias (A.Located N.Name) [A.Located N.Name] Type.Raw
79+ | Binop (A.Located N.Name) Binop.Associativity Binop.Precedence N.Name
80+ | Port (A.Located N.Name) Type.Raw
81+ | Docs Text
82+ | Annotation (A.Located N.Name) Type.Raw
83+ | Definition (A.Located N.Name) [Ptrn.Raw] Expr
84+
85+
86+
87+-- MODULE
88+
89+
90+data Module decls =
91+ Module
92+ { _name :: N.Name
93+ , _effects :: Effects
94+ , _docs :: A.Located (Maybe B.ByteString)
95+ , _exports :: Exposing
96+ , _imports :: [Import]
97+ , _decls :: decls
98+ }
99+
100+
101+data Import =
102+ Import
103+ { _import :: A.Located N.Name
104+ , _alias :: Maybe N.Name
105+ , _exposing :: Exposing
106+ }
107+
59108
109+data Effects
110+ = NoEffects
111+ | Ports R.Region
112+ | Effects R.Region Manager
60113
61−type RawDef =
62− A.Located RawDef'
63114
115+data Manager
116+ = Cmd (A.Located N.Name)
117+ | Sub (A.Located N.Name)
118+ | Fx (A.Located N.Name) (A.Located N.Name)
64119
65−data RawDef'
66− = Annotation Text Type.Raw
67− | Definition Text [Ptrn.Raw] RawExpr
68− | Destructure Ptrn.Raw RawExpr
69120
121+defaultModule :: [Import] -> decls -> Module decls
122+defaultModule imports decls =
123+ let zero = R.Position 1 1 in
124+ Module
125+ { _name = "Main"
126+ , _effects = NoEffects
127+ , _docs = A.at zero zero Nothing
128+ , _exports = Open
129+ , _imports = imports
130+ , _decls = decls
131+ }
70132
71−data ValidDef
72− = VDefinition R.Region Text [Ptrn.Raw] ValidExpr (Maybe Type.Raw)
73− | VDestructure R.Region Ptrn.Raw ValidExpr
74133
75134
135+-- EXPOSING
76136
77−-- HELPERS
78137
138+data Exposing
139+ = Open
140+ | Explicit ![A.Located Exposed]
79141
80−zero :: Expr' def
81−zero =
82− Literal (Literal.IntNum 0)
83142
143+data Exposed
144+ = Lower !Text
145+ | Upper !Text !Privacy
146+ | Operator !Text
84147
85−collectLambdas :: Expr def -> ([Ptrn.Raw], Expr def)
86−collectLambdas lexpr@(A.A _ expr) =
87− case expr of
88− Lambda pattern body ->
89− let
90− (ps, body') = collectLambdas body
91− in
92− (pattern : ps, body')
93148
94− _ ->
95− ([], lexpr)
149+data Privacy
150+ = Public
151+ | Private
src/AST/Expression/Valid.hsnew file+100
@@ -0,0 +1,100 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Expression.Valid
3+ ( Expr, Expr_(..)
4+ , Def(..)
5+ , Module(..)
6+ , Decl(..)
7+ , Union(..)
8+ , Alias(..)
9+ , Binop(..)
10+ , Effects(..)
11+ , Port(..)
12+ )
13+ where
14+
15+
16+import qualified Data.ByteString as B
17+import qualified Data.Map as Map
18+import Data.Text (Text)
19+
20+import qualified AST.Binop as Binop
21+import qualified AST.Expression.Source as Src
22+import qualified AST.Literal as Literal
23+import qualified AST.Pattern as Pattern
24+import qualified AST.Type as Type
25+import qualified Elm.Name as N
26+import qualified Reporting.Annotation as A
27+import qualified Reporting.Region as R
28+
29+
30+
31+-- EXPRESSIONS
32+
33+
34+type Expr = A.Located Expr_
35+
36+
37+data Expr_
38+ = Literal Literal.Literal
39+ | Var (Maybe N.Name) N.Name
40+ | List [Expr]
41+ | Op N.Name
42+ | Negate Expr
43+ | Binops [(Expr, A.Located N.Name)] Expr
44+ | Lambda Pattern.Raw Expr
45+ | Call Expr [Expr]
46+ | If [(Expr, Expr)] Expr
47+ | Let [Def] Expr
48+ | Case Expr [(Pattern.Raw, Expr)]
49+ | Accessor N.Name
50+ | Access Expr N.Name
51+ | Update (A.Located N.Name) [(A.Located N.Name, Expr)]
52+ | Record [(A.Located N.Name, Expr)]
53+ | Unit
54+ | Tuple Expr Expr [Expr]
55+ | GLShader Text Text Literal.Shader
56+
57+
58+
59+-- DEFINITIONS
60+
61+
62+data Def
63+ = Define R.Region N.Name [Pattern.Raw] Expr (Maybe Type.Raw)
64+ | Destruct R.Region Pattern.Raw Expr
65+
66+
67+
68+-- MODULE
69+
70+
71+data Module =
72+ Module
73+ { _name :: N.Name
74+ , _overview :: A.Located (Maybe B.ByteString)
75+ , _docs :: Map.Map N.Name Text
76+ , _exports :: Src.Exposing
77+ , _imports :: [Src.Import]
78+ , _decls :: [Decl]
79+ , _unions :: [Union]
80+ , _aliases :: [Alias]
81+ , _binop :: [Binop]
82+ , _effects :: Effects
83+ }
84+
85+
86+data Decl = Decl (A.Located N.Name) [Pattern.Raw] Expr (Maybe Type.Raw)
87+data Union = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Type.Raw])]
88+data Alias = Alias (A.Located N.Name) [A.Located N.Name] Type.Raw
89+data Binop = Binop (A.Located N.Name) Binop.Associativity Binop.Precedence N.Name
90+
91+
92+data Effects
93+ = NoEffects
94+ | Ports [Port]
95+ | Cmd (A.Located Text)
96+ | Sub (A.Located Text)
97+ | Fx (A.Located Text) (A.Located Text)
98+
99+
100+data Port = Port (A.Located N.Name) Type.Raw
src/AST/Helpers.hsdeleted−65
@@ -1,65 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module AST.Helpers
4− ( zeroTuple
5− , makeTuple
6− , isTuple
7− , isOp
8− , isSymbol
9− , desymbol
10− )
11− where
12−
13−import qualified Data.Char as Char
14−import qualified Data.Map as Map
15−import Data.Map ((!))
16−import qualified Data.Text as Text
17−import Data.Text (Text)
18−
19−
20−
21−-- TUPLES
22−
23−
24−zeroTuple :: Text
25−zeroTuple =
26− "#0"
27−
28−
29−makeTuple :: Int -> Text
30−makeTuple size =
31− Text.pack ('#' : show size)
32−
33−
34−isTuple :: Text -> Bool
35−isTuple name =
36− Text.isPrefixOf "#" name
37− &&
38− Text.all Char.isDigit (Text.drop 1 name)
39−
40−
41−
42−-- INFIX OPERATORS
43−
44−
45−isOp :: Text -> Bool
46−isOp name =
47− Text.all isSymbol name
48−
49−
50−isSymbol :: Char -> Bool
51−isSymbol c =
52− Map.member c validSymbols
53−
54−
55−validSymbols :: Map.Map Char Char
56−validSymbols =
57− Map.fromList $
58− zip
59− "+-/*=.<>:&|^?%~!"
60− "abcdefghijklmnop"
61−
62−
63−desymbol :: Text -> Text
64−desymbol name =
65− Text.map (\c -> validSymbols ! c) name
src/AST/Module.hsdeleted−245
@@ -1,245 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module AST.Module
4− ( Header(..), HeaderDecl(..), defaultHeaderDecl
5− , Module(..)
6−
7− , Source, SourceInfo(..), SourceTag(..), SourceSettings, emptySettings
8− , Valid, ValidInfo(..)
9− , Canonical, Optimized, Info(..)
10−
11− , UserImport, DefaultImport, ImportMethod(..)
12−
13− , Types
14− , Aliases
15− , Unions, UnionInfo, CanonicalUnion
16−
17− , Interfaces, Interface(..), toInterface, privatize
18− )
19− where
20−
21−import Data.Binary
22−import qualified Data.Map as Map
23−import Data.Text (Text)
24−
25−import qualified AST.Declaration as Decl
26−import qualified AST.Effects as Effects
27−import qualified AST.Exposing as Exposing
28−import qualified AST.Expression.Canonical as Canonical
29−import qualified AST.Expression.Optimized as Optimized
30−import qualified AST.Module.Name as Name
31−import qualified AST.Type as Type
32−import qualified AST.Variable as Var
33−import qualified Docs.AST as Docs
34−import qualified Reporting.Annotation as A
35−import qualified Reporting.Region as R
36−
37−
38−
39−-- HEADERS FOR PARSING
40−
41−
42−{-| Basic info needed to identify modules and determine dependencies. -}
43−data Header imports =
44− Header
45− { _decl :: Maybe HeaderDecl
46− , _imports :: imports
47− }
48−
49−
50−data HeaderDecl =
51− HeaderDecl
52− { _tag :: SourceTag
53− , _name :: Name.Raw
54− , _exports :: Exposing.Raw
55− , _settings :: SourceSettings
56− , _docs :: A.Located (Maybe Text)
57− }
58−
59−
60−defaultHeaderDecl :: HeaderDecl
61−defaultHeaderDecl =
62− let
63− zero = R.Position 1 1
64− noDocs = A.at zero zero Nothing
65− in
66− HeaderDecl Normal "Main" Exposing.Open emptySettings noDocs
67−
68−
69−
70−-- MODULES
71−
72−
73−data Module phase =
74− Module
75− { name :: Name.Canonical
76− , info :: phase
77− }
78−
79−
80−type Source =
81− Module SourceInfo
82−
83−
84−data SourceInfo =
85− Source
86− { srcTag :: SourceTag
87− , srcSettings :: SourceSettings
88− , srcDocs :: A.Located (Maybe Text)
89− , srcExports :: Exposing.Raw
90− , srcImports :: [UserImport]
91− , srcDecls :: [Decl.Source]
92− }
93−
94−
95−data SourceTag
96− = Normal
97− | Effect R.Region
98− | Port R.Region
99−
100−
101−type SourceSettings =
102− A.Located [(A.Located Text, A.Located Text)]
103−
104−
105−emptySettings :: SourceSettings
106−emptySettings =
107− A.A (error "region of empty settings should not be needed") []
108−
109−
110−type Valid =
111− Module ValidInfo
112−
113−
114−data ValidInfo =
115− Valid
116− { validDocs :: A.Located (Maybe Text)
117− , validExports :: Exposing.Raw
118− , validImports :: ([DefaultImport], [UserImport])
119− , validDecls :: Decl.Valid
120− , validEffects :: Effects.Raw
121− }
122−
123−
124−type Canonical =
125− Module (Info Canonical.Expr)
126−
127−
128−type Optimized =
129− Module (Info [(Text, Optimized.Decl)])
130−
131−
132−
133−-- IMPORTS
134−
135−
136−type UserImport = A.Located (A.Located Name.Raw, ImportMethod)
137−
138−
139−type DefaultImport = (Name.Raw, ImportMethod)
140−
141−
142−data ImportMethod =
143− ImportMethod
144− { alias :: Maybe Text
145− , exposedVars :: !Exposing.Raw
146− }
147−
148−
149−
150−-- LATE PHASE MODULE INFORMATION
151−
152−
153−data Info program =
154− Info
155− { docs :: A.Located (Maybe Docs.Centralized)
156− , exports :: Exposing.Canonical
157− , imports :: [Name.Raw]
158− , program :: program
159− , types :: Types
160− , fixities :: [Decl.Infix]
161− , aliases :: Aliases
162− , unions :: Unions
163− , effects :: Effects.Canonical
164− }
165−
166−
167−type Types =
168− Map.Map Text Type.Canonical
169−
170−
171−type Aliases =
172− Map.Map Text ([Text], Type.Canonical)
173−
174−
175−type Unions =
176− Map.Map Text (UnionInfo Text)
177−
178−
179−type UnionInfo v =
180− ( [Text], [(v, [Type.Canonical])] )
181−
182−
183−type CanonicalUnion =
184− ( Var.Canonical, UnionInfo Var.Canonical )
185−
186−
187−
188−-- INTERFACES
189−
190−
191−type Interfaces =
192− Map.Map Name.Canonical Interface
193−
194−
195−{-| Key facts about a module, used when reading info from .elmi files. -}
196−data Interface =
197− Interface
198− { iExports :: Exposing.Canonical
199− , iImports :: [Name.Raw] -- TODO perhaps use this to crawl faster
200− , iTypes :: Types
201− , iUnions :: Unions
202− , iAliases :: Aliases
203− , iFixities :: [Decl.Infix]
204− }
205−
206−
207−toInterface :: Optimized -> Interface
208−toInterface (Module _ myInfo) =
209− Interface
210− { iExports = exports myInfo
211− , iImports = imports myInfo
212− , iTypes = types myInfo
213− , iUnions = unions myInfo
214− , iAliases = aliases myInfo
215− , iFixities = fixities myInfo
216− }
217−
218−
219−privatize :: Interface -> Maybe Interface
220−privatize (Interface _ _ _ myUnions myAliases _) =
221− if Map.null myUnions && Map.null myAliases then
222− Nothing
223−
224− else
225− Just $ Interface
226− { iExports = Exposing.nothing
227− , iImports = []
228− , iTypes = Map.empty
229− , iUnions = myUnions
230− , iAliases = myAliases
231− , iFixities = []
232− }
233−
234−
235−instance Binary Interface where
236− get =
237− Interface <$> get <*> get <*> get <*> get <*> get <*> get
238−
239− put modul =
240− do put (iExports modul)
241− put (iImports modul)
242− put (iTypes modul)
243− put (iUnions modul)
244− put (iAliases modul)
245− put (iFixities modul)
src/AST/Type.hs+58−61
@@ -10,14 +10,13 @@ module AST.Type
1010 )
1111 where
1212
13−import Control.Arrow (second)
14−import Control.Monad (liftM, liftM2, liftM3, replicateM)
13+
14+import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
1515import Data.Binary
1616import qualified Data.Map as Map
17−import Data.Text (Text)
1817
1918import qualified AST.Module.Name as ModuleName
20−import qualified AST.Variable as Var
19+import Elm.Name (Name)
2120import qualified Reporting.Annotation as A
2221import qualified Reporting.Region as R
2322
@@ -31,58 +30,55 @@ type Raw =
3130
3231
3332data Raw'
34− = RLambda Raw Raw
35− | RVar Text
36− | RType R.Region (Maybe Text) Text [Raw]
37− | RRecord [(A.Located Text, Raw)] (Maybe Raw)
38− | RUnit
39− | RTuple Raw Raw [Raw]
33+ = RLambda Raw Raw
34+ | RVar Name
35+ | RType R.Region (Maybe Name) Name [Raw]
36+ | RRecord [(A.Located Name, Raw)] (Maybe Raw)
37+ | RUnit
38+ | RTuple Raw Raw [Raw]
4039
4140
4241data Canonical
43− = Lambda Canonical Canonical
44− | Var Text
45− | Type Var.Canonical [Canonical]
46− | Record [(Text, Canonical)] (Maybe Canonical)
47− | Unit
48− | Tuple Canonical Canonical [Canonical]
49− | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)
50− deriving (Eq, Ord)
42+ = Lambda Canonical Canonical
43+ | Var Name
44+ | Type ModuleName.Canonical Name [Canonical]
45+ | Record (Map.Map Name Canonical) (Maybe Canonical)
46+ | Unit
47+ | Tuple Canonical Canonical [Canonical]
48+ | Aliased ModuleName.Canonical Name [(Name, Canonical)] (Aliased Canonical)
49+ deriving (Eq, Ord)
5150
5251
5352data Aliased t
54− = Holey t
55− | Filled t
56− deriving (Eq, Ord)
53+ = Holey t
54+ | Filled t
55+ deriving (Eq, Ord)
5756
5857
5958data Super
60− = Number
61− | Comparable
62− | Appendable
63− | CompAppend
64− deriving (Eq)
59+ = Number
60+ | Comparable
61+ | Appendable
62+ | CompAppend
63+ deriving (Eq)
6564
6665
6766
6867-- CONSTRUCT USEFUL TYPES
6968
7069
71−cmd :: ModuleName.Canonical -> Text -> Canonical
72−cmd =
73− effect Var.cmd
74−
75−
76−sub :: ModuleName.Canonical -> Text -> Canonical
77−sub =
78− effect Var.sub
70+cmd :: ModuleName.Canonical -> Name -> Canonical
71+cmd moduleName tipe =
72+ Lambda
73+ (Type moduleName tipe [Var "msg"])
74+ (Type (ModuleName.inCore "Platform.Cmd") "Cmd" [Var "msg"])
7975
8076
81−effect :: Var.Canonical -> ModuleName.Canonical -> Text -> Canonical
82−effect effectName moduleName tipe =
77+sub :: ModuleName.Canonical -> Name -> Canonical
78+sub moduleName tipe =
8379 Lambda
84− (Type (Var.fromModule moduleName tipe) [Var "msg"])
85− (Type effectName [Var "msg"])
80+ (Type moduleName tipe [Var "msg"])
81+ (Type (ModuleName.inCore "Platform.Sub") "Sub" [Var "msg"])
8682
8783
8884
@@ -99,13 +95,13 @@ deepDealias tipe =
9995 tipe
10096
10197 Record fields ext ->
102− Record (map (second deepDealias) fields) (fmap deepDealias ext)
98+ Record (Map.map deepDealias fields) (fmap deepDealias ext)
10399
104− Aliased _name args tipe' ->
100+ Aliased _ _ args tipe' ->
105101 deepDealias (dealias args tipe')
106102
107− Type name args ->
108− Type name (map deepDealias args)
103+ Type home name args ->
104+ Type home name (map deepDealias args)
109105
110106 Unit ->
111107 Unit
@@ -117,14 +113,14 @@ deepDealias tipe =
117113iteratedDealias :: Canonical -> Canonical
118114iteratedDealias tipe =
119115 case tipe of
120− Aliased _ args realType ->
116+ Aliased _ _ args realType ->
121117 iteratedDealias (dealias args realType)
122118
123119 _ ->
124120 tipe
125121
126122
127−dealias :: [(Text, Canonical)] -> Aliased Canonical -> Canonical
123+dealias :: [(Name, Canonical)] -> Aliased Canonical -> Canonical
128124dealias args aliasType =
129125 case aliasType of
130126 Holey tipe ->
@@ -134,7 +130,7 @@ dealias args aliasType =
134130 tipe
135131
136132
137−dealiasHelp :: Map.Map Text Canonical -> Canonical -> Canonical
133+dealiasHelp :: Map.Map Name Canonical -> Canonical -> Canonical
138134dealiasHelp typeTable tipe =
139135 let
140136 go =
@@ -148,13 +144,13 @@ dealiasHelp typeTable tipe =
148144 Map.findWithDefault tipe x typeTable
149145
150146 Record fields ext ->
151− Record (map (second go) fields) (fmap go ext)
147+ Record (Map.map go fields) (fmap go ext)
152148
153− Aliased original args t' ->
154− Aliased original (map (second go) args) t'
149+ Aliased home name args t' ->
150+ Aliased home name (map (fmap go) args) t'
155151
156− Type name args ->
157− Type name (map go args)
152+ Type home name args ->
153+ Type home name (map go args)
158154
159155 Unit ->
160156 Unit
@@ -184,23 +180,24 @@ collectLambdas tipe =
184180instance Binary Canonical where
185181 put tipe =
186182 case tipe of
187− Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
188− Var x -> putWord8 1 >> put x
189− Record fs ext -> putWord8 2 >> put fs >> put ext
190− Unit -> putWord8 3
191− Tuple a b cs -> putWord8 4 >> put a >> put b >> put cs
192− Aliased var args t -> putWord8 5 >> put var >> put args >> put t
193− Type name ts ->
183+ Lambda a b -> putWord8 0 >> put a >> put b
184+ Var a -> putWord8 1 >> put a
185+ Record a b -> putWord8 2 >> put a >> put b
186+ Unit -> putWord8 3
187+ Tuple a b c -> putWord8 4 >> put a >> put b >> put c
188+ Aliased a b c d -> putWord8 5 >> put a >> put b >> put c >> put d
189+ Type home name ts ->
194190 let
195191 potentialWord =
196192 length ts + 7
197193 in
198194 if potentialWord <= fromIntegral (maxBound :: Word8) then
199195 do putWord8 (fromIntegral potentialWord)
196+ put home
200197 put name
201198 mapM_ put ts
202199 else
203− putWord8 6 >> put name >> put ts
200+ putWord8 6 >> put home >> put name >> put ts
204201
205202 get =
206203 do word <- getWord8
@@ -210,9 +207,9 @@ instance Binary Canonical where
210207 2 -> liftM2 Record get get
211208 3 -> return Unit
212209 4 -> liftM3 Tuple get get get
213− 5 -> liftM3 Aliased get get get
214− 6 -> liftM2 Type get get
215− n -> liftM2 Type get (replicateM (fromIntegral (n - 7)) get)
210+ 5 -> liftM4 Aliased get get get get
211+ 6 -> liftM3 Type get get get
212+ n -> liftM3 Type get get (replicateM (fromIntegral (n - 7)) get)
216213
217214
218215instance Binary t => Binary (Aliased t) where
src/AST/Variable.hs+5−45
@@ -1,19 +1,18 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module AST.Variable
4− ( Raw(..)
5− , Canonical(..), Home(..)
4+ ( Canonical(..), Home(..)
65 , Global(..)
76 , local, topLevel, fromModule
87 , inCore, inHtml
9− , int, float, char, string, tuple
8+ , int, float, char, string
109 , list, cons, nil
1110 , bool, true, false
12− , never, task, cmd, sub, router, shader, decoder
11+ , never, task, router, shader, decoder
1312 , isLocalHome, isCons
1413 , is, isJson, isMaybe, isArray, isTask, isList
15− , isKernel, isTuple, isPrim, isLocal
16− , rawToText, toText
14+ , isKernel, isPrim, isLocal
15+ , toText
1716 )
1817 where
1918
@@ -21,20 +20,11 @@ import Data.Binary
2120import Data.Monoid ((<>))
2221import Data.Text (Text)
2322
24−import qualified AST.Helpers as Help
2523import qualified AST.Module.Name as ModuleName
2624import qualified Elm.Package as Pkg
2725
2826
2927
30−-- RAW NAMES
31−
32−
33−newtype Raw = Raw Text
34− deriving (Eq, Ord)
35−
36−
37−
3828-- CANONICAL NAMES
3929
4030
@@ -115,11 +105,6 @@ string =
115105 Canonical BuiltIn "String"
116106
117107
118−tuple :: Int -> Canonical
119−tuple size =
120− Canonical BuiltIn (Help.makeTuple size)
121−
122−
123108
124109-- LIST
125110
@@ -172,16 +157,6 @@ task =
172157 inCore "Platform" "Task"
173158
174159
175−cmd :: Canonical
176−cmd =
177− inCore "Platform.Cmd" "Cmd"
178−
179−
180−sub :: Canonical
181−sub =
182− inCore "Platform.Sub" "Sub"
183−
184−
185160router :: Canonical
186161router =
187162 inCore "Platform" "Router"
@@ -266,16 +241,6 @@ isKernel var =
266241 False
267242
268243
269−isTuple :: Canonical -> Bool
270−isTuple var =
271− case var of
272− Canonical BuiltIn name ->
273− Help.isTuple name
274−
275− _ ->
276− False
277−
278−
279244isPrim :: Text -> Canonical -> Bool
280245isPrim prim (Canonical home name) =
281246 case home of
@@ -300,11 +265,6 @@ isLocal check (Canonical home name) =
300265-- VARIABLE TO TEXT
301266
302267
303−rawToText :: Raw -> Text
304−rawToText (Raw name) =
305− name
306−
307−
308268toText :: Canonical -> Text
309269toText (Canonical home name) =
310270 case home of