git.iko.soy/elk
on master help sign in
Reformulate AST for changes in validation / canonicalization
959c23dEvan Czaplicki
src/AST/Binop.hsnew file+55
compare with master
unifiedsplit
@@ -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 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module AST.Expression.Canonical
3module AST.Expression.Canonical
4− ( Expr, Expr'(..)
4+ ( Expr
5− , Main(..)
5+ , Expr_(..)
6 , Def(..)
6 , Def(..)
7− , SortedDefs(..), toSortedDefs
7+ , Decl(..)
8− , localVar
8+ , Module(..)
9− , collectApps, collectFields, collectLambdas
9+ , Alias(..)
10+ , Union(..)
11+ , Binop(..)
12+ , Effects(..)
13+ , Port(..)
14+ , Docs(..)
10 )
15 )
11 where
16 where
12
17
13
18
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
15import Data.Text (Text)
23import Data.Text (Text)
16−import qualified Data.Text.Lazy as LText
17−import qualified Data.Text.Lazy.Builder as B
18
24
19−import qualified AST.Effects as Effects
25+import qualified AST.Binop as Binop
20import qualified AST.Literal as Literal
26import qualified AST.Literal as Literal
21import qualified AST.Module.Name as ModuleName
27import qualified AST.Module.Name as ModuleName
22import qualified AST.Pattern as Ptrn
28import qualified AST.Pattern as Ptrn
23import qualified AST.Type as Type
29import qualified AST.Type as Type
24import qualified AST.Variable as Var
30import qualified AST.Variable as Var
31+import qualified Elm.Name as N
32+import Elm.Name (Name)
25import qualified Reporting.Annotation as A
33import qualified Reporting.Annotation as A
26import qualified Reporting.Region as R
34import qualified Reporting.Region as R
27
35
@@ -31,36 +39,31 @@ import qualified Reporting.Region as R
31
39
32
40
33type Expr =
41type Expr =
34− A.Annotated R.Region Expr'
42+ A.Annotated R.Region Expr_
35−
43+
36−
44+
37−data Expr'
45+data Expr_
38− = Literal Literal.Literal
46+ = VarLocal Name
39− | Var Var.Canonical
47+ | VarTopLevel ModuleName.Canonical Name
48+ | VarKernel Name Name
49+ | VarForeign ModuleName.Canonical Name
50+ | VarOperator ModuleName.Canonical Name Name
51+ | Literal Literal.Literal
40− | List [Expr]
52+ | List [Expr]
41− | Binop Var.Canonical Expr Expr
53+ | Binop Name ModuleName.Canonical Name Expr Expr
42− | Lambda Ptrn.Canonical Expr
54+ | Lambda Ptrn.Canonical Expr
43− | App Expr Expr
55+ | Call Expr [Expr]
44− | If [(Expr, Expr)] Expr
56+ | If [(Expr, Expr)] Expr
45− | Let [Def] Expr
57+ | Let [Graph.SCC Def] Expr
46− | Case Expr [(Ptrn.Canonical, Expr)]
58+ | Case Expr [(Ptrn.Canonical, Expr)]
47− | Ctor Var.Canonical [Expr]
59+ | CtorAccess Expr Int
60+ | Accessor Name
48− | Access Expr Text
61+ | Access Expr Name
49− | Update Expr [(Text, Expr)]
62+ | Update Expr [(Name, Expr)]
50− | Record [(Text, Expr)]
63+ | Record [(Name, Expr)]
51− -- for type checking and code gen only
64+ | Unit
52− | Cmd ModuleName.Canonical Effects.ManagerType
65+ | Tuple Expr Expr [Expr]
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
66+ | GLShader Name Name Literal.Shader
59−
60−
61−data Main
62− = Static
63− | Dynamic Type.Canonical
64
67
65
68
66
69
@@ -69,93 +72,84 @@ data Main
69
72
70data Def =
73data Def =
71 Def
74 Def
72− { _region :: R.Region
75+ { _let_name :: Text
73− , _pattern :: Ptrn.Canonical
76+ , _let_args :: [A.Located Ptrn.Canonical]
74− , _body :: Expr
77+ , _let_body :: Expr
75− , _type :: Maybe (A.Located Type.Canonical)
78+ , _let_type :: Maybe (A.Located Type.Canonical)
76 }
79 }
77
80
78
81
79
82
80−-- SORTED DEFS
83+-- DECLARATIONS
81
84
82
85
83−data SortedDefs
86+data Decl =
84− = NoMain [Def]
87+ Decl
85− | YesMain [Def] Def [Def]
88+ { _top_name :: Text
86−
89+ , _top_args :: [A.Located Ptrn.Canonical]
87−
90+ , _top_body :: Expr
88−toSortedDefs :: Expr -> SortedDefs
91+ , _top_type :: Maybe (A.Located Type.Canonical)
89−toSortedDefs (A.A _ expr) =
92+ , _top_deps :: [Var.Global]
90− case expr of
93+ }
91− Let defs body ->
92− foldr defCons (toSortedDefs body) defs
93
94
94− _ ->
95− NoMain []
96
95
97
96
98−defCons :: Def -> SortedDefs -> SortedDefs
97+-- MODULES
99−defCons def@(Def _ (A.A _ pattern) _ _) sortedDefs =
100− case (pattern, sortedDefs) of
101− (Ptrn.Var "main", NoMain defs) ->
102− YesMain [] def defs
103
98
104− (_, NoMain defs) ->
105− NoMain (def : defs)
106
99
107− (_, YesMain defs main rest) ->
100+data Module phase =
108− YesMain (def : defs) main rest
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+ }
109
111
110
112
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
111
116
112−-- HELPERS
117+data Effects
118+ = NoEffects
119+ | Ports [Port]
120+ | Cmd
121+ | Sub
122+ | Fx
113
123
114
124
115−localVar :: Text -> Expr'
125+data Port = Port R.Region N.Name Type.Canonical
116−localVar x =
117− Var (Var.Canonical Var.Local x)
118
126
119
127
120−-- COLLECTORS
121
128
129+-- DOCS
122
130
123−collectApps :: Expr -> [Expr]
124−collectApps annExpr@(A.A _ expr) =
125− case expr of
126− App a b ->
127− collectApps a ++ [b]
128
131
129− _ ->
132+data Docs =
130− [annExpr]
133+ Docs
134+ { _overview :: Text
135+ , _comments :: Map.Map N.Name Text
136+ }
131
137
132
138
133−collectFields :: Expr -> Maybe Text
134−collectFields expr =
135− fmap (LText.toStrict . B.toLazyText) (collectFieldsHelp expr mempty)
136
139
140+-- BINARY
137
141
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)
143
142
144− Access record field ->
143+instance Binary Alias where
145− collectFieldsHelp record ("." <> B.fromText field <> builder)
144+ get = liftM2 Alias get get
145+ put (Alias a b) = put a >> put b
146
146
147− _ ->
148− Nothing
149
147
148+instance Binary Union where
149+ get = liftM2 Union get get
150+ put (Union a b) = put a >> put b
150
151
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')
159
152
160− _ ->
153+instance Binary Binop where
161− ([], lexpr)
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 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module AST.Expression.Source
3module AST.Expression.Source
3− ( RawExpr, RawExpr', RawDef, RawDef'(..)
4+ ( Expr, Expr_(..)
4− , ValidExpr, ValidExpr', ValidDef(..)
5+ , Decl, Decl_(..)
5− , Expr, Expr'(..)
6+ , Def(..)
6− , zero, collectLambdas
7+ , Module(..)
8+ , Import(..)
9+ , Effects(..)
10+ , Manager(..)
11+ , defaultModule
12+ , Exposing(..)
13+ , Exposed(..)
14+ , Privacy(..)
7 )
15 )
8 where
16 where
9
17
10
18
19+import qualified Data.ByteString as B
11import Data.Text (Text)
20import Data.Text (Text)
12
21
22+import qualified AST.Binop as Binop
13import qualified AST.Literal as Literal
23import qualified AST.Literal as Literal
14import qualified AST.Pattern as Ptrn
24import qualified AST.Pattern as Ptrn
15import qualified AST.Type as Type
25import qualified AST.Type as Type
26+import qualified Elm.Name as N
16import qualified Reporting.Annotation as A
27import qualified Reporting.Annotation as A
17import qualified Reporting.Region as R
28import qualified Reporting.Region as R
18
29
@@ -21,75 +32,120 @@ import qualified Reporting.Region as R
21-- EXPRESSIONS
32-- EXPRESSIONS
22
33
23
34
24−type Expr def =
35+type Expr = A.Located Expr_
25− A.Located (Expr' def)
26
36
27
37
28−data Expr' def
38+data Expr_
29− = Literal Literal.Literal
39+ = Literal Literal.Literal
30− | Var (Maybe Text) Text
40+ | Var (Maybe N.Name) N.Name
31− | List [Expr def]
41+ | List [Expr]
32− | Op Text
42+ | Op N.Name
43+ | Negate Expr
33− | Binop [(Expr def, A.Located Text)] (Expr def)
44+ | Binops [(Expr, A.Located N.Name)] Expr
34− | Lambda Ptrn.Raw (Expr def)
45+ | Lambda Ptrn.Raw Expr
35− | App (Expr def) (Expr def)
46+ | Call Expr [Expr]
36− | If [(Expr def, Expr def)] (Expr def)
47+ | If [(Expr, Expr)] Expr
37− | Let [def] (Expr def)
48+ | Let [A.Located Def] Expr
38− | Case (Expr def) [(Ptrn.Raw, Expr def)]
49+ | Case Expr [(Ptrn.Raw, Expr)]
39− | Accessor Text
50+ | Accessor N.Name
40− | Access (Expr def) Text
51+ | Access Expr N.Name
41− | Update (A.Located Text) [(A.Located Text, Expr def)]
52+ | Update (A.Located N.Name) [(A.Located N.Name, Expr)]
42− | Record [(A.Located Text, Expr def)]
53+ | Record [(A.Located N.Name, Expr)]
43− | Unit
54+ | Unit
44− | Tuple (Expr def) (Expr def) [Expr def]
55+ | Tuple Expr Expr [Expr]
45− | GLShader Text Text Literal.Shader
56+ | GLShader Text Text Literal.Shader
46
57
47
58
48−type RawExpr = Expr RawDef
49
59
50−type RawExpr' = Expr' RawDef
60+-- DEFINITIONS
51
61
52−type ValidExpr = Expr ValidDef
53
62
54−type ValidExpr' = Expr' ValidDef
63+data Def
64+ = Annotate Text Type.Raw
65+ | Define Text [Ptrn.Raw] Expr
66+ | Destruct Ptrn.Raw Expr
55
67
56
68
57
69
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+
59
108
109+data Effects
110+ = NoEffects
111+ | Ports R.Region
112+ | Effects R.Region Manager
60
113
61−type RawDef =
62− A.Located RawDef'
63
114
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)
64
119
65−data RawDef'
66− = Annotation Text Type.Raw
67− | Definition Text [Ptrn.Raw] RawExpr
68− | Destructure Ptrn.Raw RawExpr
69
120
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+ }
70
132
71−data ValidDef
72− = VDefinition R.Region Text [Ptrn.Raw] ValidExpr (Maybe Type.Raw)
73− | VDestructure R.Region Ptrn.Raw ValidExpr
74
133
75
134
135+-- EXPOSING
76
136
77−-- HELPERS
78
137
138+data Exposing
139+ = Open
140+ | Explicit ![A.Located Exposed]
79
141
80−zero :: Expr' def
81−zero =
82− Literal (Literal.IntNum 0)
83
142
143+data Exposed
144+ = Lower !Text
145+ | Upper !Text !Privacy
146+ | Operator !Text
84
147
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')
93
148
94− _ ->
149+data Privacy
95− ([], lexpr)
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
10 )
10 )
11 where
11 where
12
12
13−import Control.Arrow (second)
13+
14−import Control.Monad (liftM, liftM2, liftM3, replicateM)
14+import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
15import Data.Binary
15import Data.Binary
16import qualified Data.Map as Map
16import qualified Data.Map as Map
17−import Data.Text (Text)
18
17
19import qualified AST.Module.Name as ModuleName
18import qualified AST.Module.Name as ModuleName
20−import qualified AST.Variable as Var
19+import Elm.Name (Name)
21import qualified Reporting.Annotation as A
20import qualified Reporting.Annotation as A
22import qualified Reporting.Region as R
21import qualified Reporting.Region as R
23
22
@@ -31,58 +30,55 @@ type Raw =
31
30
32
31
33data Raw'
32data Raw'
34− = RLambda Raw Raw
33+ = RLambda Raw Raw
35− | RVar Text
34+ | RVar Name
36− | RType R.Region (Maybe Text) Text [Raw]
35+ | RType R.Region (Maybe Name) Name [Raw]
37− | RRecord [(A.Located Text, Raw)] (Maybe Raw)
36+ | RRecord [(A.Located Name, Raw)] (Maybe Raw)
38− | RUnit
37+ | RUnit
39− | RTuple Raw Raw [Raw]
38+ | RTuple Raw Raw [Raw]
40
39
41
40
42data Canonical
41data Canonical
43− = Lambda Canonical Canonical
42+ = Lambda Canonical Canonical
44− | Var Text
43+ | Var Name
45− | Type Var.Canonical [Canonical]
44+ | Type ModuleName.Canonical Name [Canonical]
46− | Record [(Text, Canonical)] (Maybe Canonical)
45+ | Record (Map.Map Name Canonical) (Maybe Canonical)
47− | Unit
46+ | Unit
48− | Tuple Canonical Canonical [Canonical]
47+ | Tuple Canonical Canonical [Canonical]
49− | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)
48+ | Aliased ModuleName.Canonical Name [(Name, Canonical)] (Aliased Canonical)
50− deriving (Eq, Ord)
49+ deriving (Eq, Ord)
51
50
52
51
53data Aliased t
52data Aliased t
54− = Holey t
53+ = Holey t
55− | Filled t
54+ | Filled t
56− deriving (Eq, Ord)
55+ deriving (Eq, Ord)
57
56
58
57
59data Super
58data Super
60− = Number
59+ = Number
61− | Comparable
60+ | Comparable
62− | Appendable
61+ | Appendable
63− | CompAppend
62+ | CompAppend
64− deriving (Eq)
63+ deriving (Eq)
65
64
66
65
67
66
68-- CONSTRUCT USEFUL TYPES
67-- CONSTRUCT USEFUL TYPES
69
68
70
69
71−cmd :: ModuleName.Canonical -> Text -> Canonical
70+cmd :: ModuleName.Canonical -> Name -> Canonical
72−cmd =
71+cmd moduleName tipe =
73− effect Var.cmd
72+ Lambda
74−
73+ (Type moduleName tipe [Var "msg"])
75−
74+ (Type (ModuleName.inCore "Platform.Cmd") "Cmd" [Var "msg"])
76−sub :: ModuleName.Canonical -> Text -> Canonical
77−sub =
78− effect Var.sub
79
75
80
76
81−effect :: Var.Canonical -> ModuleName.Canonical -> Text -> Canonical
77+sub :: ModuleName.Canonical -> Name -> Canonical
82−effect effectName moduleName tipe =
78+sub moduleName tipe =
83 Lambda
79 Lambda
84− (Type (Var.fromModule moduleName tipe) [Var "msg"])
80+ (Type moduleName tipe [Var "msg"])
85− (Type effectName [Var "msg"])
81+ (Type (ModuleName.inCore "Platform.Sub") "Sub" [Var "msg"])
86
82
87
83
88
84
@@ -99,13 +95,13 @@ deepDealias tipe =
99 tipe
95 tipe
100
96
101 Record fields ext ->
97 Record fields ext ->
102− Record (map (second deepDealias) fields) (fmap deepDealias ext)
98+ Record (Map.map deepDealias fields) (fmap deepDealias ext)
103
99
104− Aliased _name args tipe' ->
100+ Aliased _ _ args tipe' ->
105 deepDealias (dealias args tipe')
101 deepDealias (dealias args tipe')
106
102
107− Type name args ->
103+ Type home name args ->
108− Type name (map deepDealias args)
104+ Type home name (map deepDealias args)
109
105
110 Unit ->
106 Unit ->
111 Unit
107 Unit
@@ -117,14 +113,14 @@ deepDealias tipe =
117iteratedDealias :: Canonical -> Canonical
113iteratedDealias :: Canonical -> Canonical
118iteratedDealias tipe =
114iteratedDealias tipe =
119 case tipe of
115 case tipe of
120− Aliased _ args realType ->
116+ Aliased _ _ args realType ->
121 iteratedDealias (dealias args realType)
117 iteratedDealias (dealias args realType)
122
118
123 _ ->
119 _ ->
124 tipe
120 tipe
125
121
126
122
127−dealias :: [(Text, Canonical)] -> Aliased Canonical -> Canonical
123+dealias :: [(Name, Canonical)] -> Aliased Canonical -> Canonical
128dealias args aliasType =
124dealias args aliasType =
129 case aliasType of
125 case aliasType of
130 Holey tipe ->
126 Holey tipe ->
@@ -134,7 +130,7 @@ dealias args aliasType =
134 tipe
130 tipe
135
131
136
132
137−dealiasHelp :: Map.Map Text Canonical -> Canonical -> Canonical
133+dealiasHelp :: Map.Map Name Canonical -> Canonical -> Canonical
138dealiasHelp typeTable tipe =
134dealiasHelp typeTable tipe =
139 let
135 let
140 go =
136 go =
@@ -148,13 +144,13 @@ dealiasHelp typeTable tipe =
148 Map.findWithDefault tipe x typeTable
144 Map.findWithDefault tipe x typeTable
149
145
150 Record fields ext ->
146 Record fields ext ->
151− Record (map (second go) fields) (fmap go ext)
147+ Record (Map.map go fields) (fmap go ext)
152
148
153− Aliased original args t' ->
149+ Aliased home name args t' ->
154− Aliased original (map (second go) args) t'
150+ Aliased home name (map (fmap go) args) t'
155
151
156− Type name args ->
152+ Type home name args ->
157− Type name (map go args)
153+ Type home name (map go args)
158
154
159 Unit ->
155 Unit ->
160 Unit
156 Unit
@@ -184,23 +180,24 @@ collectLambdas tipe =
184instance Binary Canonical where
180instance Binary Canonical where
185 put tipe =
181 put tipe =
186 case tipe of
182 case tipe of
187− Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
183+ Lambda a b -> putWord8 0 >> put a >> put b
188− Var x -> putWord8 1 >> put x
184+ Var a -> putWord8 1 >> put a
189− Record fs ext -> putWord8 2 >> put fs >> put ext
185+ Record a b -> putWord8 2 >> put a >> put b
190− Unit -> putWord8 3
186+ Unit -> putWord8 3
191− Tuple a b cs -> putWord8 4 >> put a >> put b >> put cs
187+ Tuple a b c -> putWord8 4 >> put a >> put b >> put c
192− Aliased var args t -> putWord8 5 >> put var >> put args >> put t
188+ Aliased a b c d -> putWord8 5 >> put a >> put b >> put c >> put d
193− Type name ts ->
189+ Type home name ts ->
194 let
190 let
195 potentialWord =
191 potentialWord =
196 length ts + 7
192 length ts + 7
197 in
193 in
198 if potentialWord <= fromIntegral (maxBound :: Word8) then
194 if potentialWord <= fromIntegral (maxBound :: Word8) then
199 do putWord8 (fromIntegral potentialWord)
195 do putWord8 (fromIntegral potentialWord)
196+ put home
200 put name
197 put name
201 mapM_ put ts
198 mapM_ put ts
202 else
199 else
203− putWord8 6 >> put name >> put ts
200+ putWord8 6 >> put home >> put name >> put ts
204
201
205 get =
202 get =
206 do word <- getWord8
203 do word <- getWord8
@@ -210,9 +207,9 @@ instance Binary Canonical where
210 2 -> liftM2 Record get get
207 2 -> liftM2 Record get get
211 3 -> return Unit
208 3 -> return Unit
212 4 -> liftM3 Tuple get get get
209 4 -> liftM3 Tuple get get get
213− 5 -> liftM3 Aliased get get get
210+ 5 -> liftM4 Aliased get get get get
214− 6 -> liftM2 Type get get
211+ 6 -> liftM3 Type get get get
215− n -> liftM2 Type get (replicateM (fromIntegral (n - 7)) get)
212+ n -> liftM3 Type get get (replicateM (fromIntegral (n - 7)) get)
216
213
217
214
218instance Binary t => Binary (Aliased t) where
215instance Binary t => Binary (Aliased t) where
src/AST/Variable.hs+5−45
@@ -1,19 +1,18 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module AST.Variable
3module AST.Variable
4− ( Raw(..)
5− , Canonical(..), Home(..)
4+ ( Canonical(..), Home(..)
6 , Global(..)
5 , Global(..)
7 , local, topLevel, fromModule
6 , local, topLevel, fromModule
8 , inCore, inHtml
7 , inCore, inHtml
9− , int, float, char, string, tuple
8+ , int, float, char, string
10 , list, cons, nil
9 , list, cons, nil
11 , bool, true, false
10 , bool, true, false
12− , never, task, cmd, sub, router, shader, decoder
11+ , never, task, router, shader, decoder
13 , isLocalHome, isCons
12 , isLocalHome, isCons
14 , is, isJson, isMaybe, isArray, isTask, isList
13 , is, isJson, isMaybe, isArray, isTask, isList
15− , isKernel, isTuple, isPrim, isLocal
14+ , isKernel, isPrim, isLocal
16− , rawToText, toText
15+ , toText
17 )
16 )
18 where
17 where
19
18
@@ -21,20 +20,11 @@ import Data.Binary
21import Data.Monoid ((<>))
20import Data.Monoid ((<>))
22import Data.Text (Text)
21import Data.Text (Text)
23
22
24−import qualified AST.Helpers as Help
25import qualified AST.Module.Name as ModuleName
23import qualified AST.Module.Name as ModuleName
26import qualified Elm.Package as Pkg
24import qualified Elm.Package as Pkg
27
25
28
26
29
27
30−-- RAW NAMES
31−
32−
33−newtype Raw = Raw Text
34− deriving (Eq, Ord)
35−
36−
37−
38-- CANONICAL NAMES
28-- CANONICAL NAMES
39
29
40
30
@@ -115,11 +105,6 @@ string =
115 Canonical BuiltIn "String"
105 Canonical BuiltIn "String"
116
106
117
107
118−tuple :: Int -> Canonical
119−tuple size =
120− Canonical BuiltIn (Help.makeTuple size)
121−
122−
123
108
124-- LIST
109-- LIST
125
110
@@ -172,16 +157,6 @@ task =
172 inCore "Platform" "Task"
157 inCore "Platform" "Task"
173
158
174
159
175−cmd :: Canonical
176−cmd =
177− inCore "Platform.Cmd" "Cmd"
178−
179−
180−sub :: Canonical
181−sub =
182− inCore "Platform.Sub" "Sub"
183−
184−
185router :: Canonical
160router :: Canonical
186router =
161router =
187 inCore "Platform" "Router"
162 inCore "Platform" "Router"
@@ -266,16 +241,6 @@ isKernel var =
266 False
241 False
267
242
268
243
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−
279isPrim :: Text -> Canonical -> Bool
244isPrim :: Text -> Canonical -> Bool
280isPrim prim (Canonical home name) =
245isPrim prim (Canonical home name) =
281 case home of
246 case home of
@@ -300,11 +265,6 @@ isLocal check (Canonical home name) =
300-- VARIABLE TO TEXT
265-- VARIABLE TO TEXT
301
266
302
267
303−rawToText :: Raw -> Text
304−rawToText (Raw name) =
305− name
306−
307−
308toText :: Canonical -> Text
268toText :: Canonical -> Text
309toText (Canonical home name) =
269toText (Canonical home name) =
310 case home of
270 case home of