elm-compiler 0.14.1 → 0.15
raw patch · 50 files changed
+3734/−2195 lines, 50 filesdep +edit-distancedep ~language-ecmascriptnew-component:exe:elmPVP ok
version bump matches the API change (PVP)
Dependencies added: edit-distance
Dependency ranges changed: language-ecmascript
API changes (from Hackage documentation)
+ Elm.Compiler: rawVersion :: [Int]
Files
- changelog.md +113/−27
- elm-compiler.cabal +41/−4
- src/AST/Declaration.hs +81/−41
- src/AST/Expression/Canonical.hs +19/−7
- src/AST/Expression/General.hs +93/−58
- src/AST/Expression/Source.hs +14/−7
- src/AST/Expression/Valid.hs +19/−7
- src/AST/Helpers.hs +8/−6
- src/AST/Module.hs +47/−30
- src/AST/Pattern.hs +61/−31
- src/AST/PrettyPrint.hs +23/−5
- src/AST/Type.hs +211/−45
- src/AST/Variable.hs +26/−3
- src/CommandLineRouter.hs +73/−0
- src/Docs.hs +20/−7
- src/Elm/Compiler.hs +6/−1
- src/Elm/Compiler/Module.hs +1/−1
- src/Elm/Compiler/Type.hs +6/−1
- src/Elm/Compiler/Type/Extract.hs +2/−2
- src/Elm/Compiler/Version.hs +6/−1
- src/Elm/Utils.hs +2/−2
- src/Generate/JavaScript.hs +153/−132
- src/Generate/JavaScript/Port.hs +277/−0
- src/Generate/JavaScript/Ports.hs +0/−217
- src/Parse/Declaration.hs +36/−23
- src/Parse/Expression.hs +142/−119
- src/Parse/Helpers.hs +36/−24
- src/Parse/Module.hs +17/−12
- src/Transform/AddDefaultImports.hs +12/−62
- src/Transform/Canonicalize.hs +104/−60
- src/Transform/Canonicalize/Environment.hs +69/−50
- src/Transform/Canonicalize/Port.hs +156/−0
- src/Transform/Canonicalize/Setup.hs +158/−87
- src/Transform/Canonicalize/Type.hs +13/−25
- src/Transform/Canonicalize/Variable.hs +177/−30
- src/Transform/Check.hs +116/−77
- src/Transform/Declaration.hs +90/−61
- src/Transform/Definition.hs +25/−20
- src/Transform/Expression.hs +39/−55
- src/Transform/SortDefinitions.hs +110/−78
- src/Transform/Substitute.hs +15/−7
- src/Type/Constrain/Expression.hs +202/−131
- src/Type/Environment.hs +155/−87
- src/Type/ExtraChecks.hs +86/−104
- src/Type/Inference.hs +1/−3
- src/Type/State.hs +98/−59
- src/Type/Type.hs +337/−229
- src/Type/Unify.hs +106/−80
- tests/Test/Compiler.hs +3/−3
- tests/Test/Property/Arbitrary.hs +129/−74
changelog.md view
@@ -1,15 +1,103 @@+# 0.15 -## 0.14+### Improve Import Syntax -#### Breaking Changes+The changes in 0.14 meant that people were seeing pretty long import sections,+sometimes with two lines for a single module to bring it in qualified and to+expose some unqualified values. The new syntax is like this: +```elm+import List+ -- Just bring `List` into scope, allowing you to say `List.map`,+ -- `List.filter`, etc.++import List exposing (map, filter)+ -- Bring `List` into scope, but also bring in `map` and `filter`+ -- without any prefix.++import List exposing (..)+ -- Bring `List` into scope, and bring in all the values in the+ -- module without a prefix.++import List as L+ -- Bring `L` into scope, but not `List`. This lets you say `L.map`,+ -- `L.filter`, etc.++import List as L exposing (map, filter)+ -- Bring `L` into scope along with unqualified versions of `map`+ -- and `filter`.++import List as L exposing (..)+ -- Bring in all the values unqualified and qualified with `L`.+```++This means you are doing more with each import, writing less overall. It also+makes the default imports more comprehensive because you now can refer to+`List` and `Result` without importing them explicitly as they are in the+defaults.++### Revise Port Syntax++One common confusion with the `port` syntax is that the only difference+between incoming ports and outgoing ports is whether the type annotation comes+with a definition. To make things a bit clearer, we are using the keywords+`foreign input` and `foreign output`.++```elm+foreign input dbResults : Stream String++foreign output dbRequests : Stream String+foreign output dbRequests =+ Stream.map toRequest userNames+```++### Input / Output++The biggest change in 0.15 is the addition of tasks, allowing us to represent+arbitrary effects in Elm in a safe way. This parallels how ports work, so we+are trying to draw attention to that in syntax. First addition is a way to+create new inputs to an Elm program.++```elm+input actions : Input Action+```++This creates a `Input` that is made up of an `Address` you can send messages to+and a `Stream` of those messages. This is similar to a `foreign input` except+there we use the name as the address. The second addition is a way to run+tasks.++```elm+output Stream.map toRequest userNames+```++This lets us turn tasks into effects in the world. Sometimes it is useful to+pipe the results of these tasks back into Elm. For that, we have the third and+final addition.++```elm+input results : Stream (Result Http.Error String)+input results from+ Stream.map toRequest userNames+```++# 0.14.1++Modify default import of `List` to expose `(::)` as well.+++# 0.14++### Breaking Changes+ * Keyword `data` renamed to `type` * Keyword `type` renamed to `type alias` -## 0.13 -#### Improvements:+# 0.13 +### Improvements:+ * Type aliases in port types * Add Keyboard.alt and Keyboard.meta * Add Debug.crash, Debug.watch, Debug.watchSummary, and Debug.trace@@ -24,7 +112,7 @@ safer, setting things up for giving programmatic access to the AST to improve editor and IDE support. -#### Breaking Changes:+### Breaking Changes: * Rename (.) to (<<) as in F# * Rename Basics.id to Basics.identity@@ -36,30 +124,30 @@ * Unambiguous syntax for importing ADTs and type aliases * sqrt and logBase both only work on Floats now -## 0.12.3+# 0.12.3 * Minor changes to support webgl as a separate library * Switch from HSV to HSL * Programmatic access to colors with toHsl and toRgb -## 0.12.1+# 0.12.1 -#### Improvements:+### Improvements: * New Array library (thanks entirely to @Xashili) * Json.Value can flow through ports * Improve speed and stack usage in List library (thanks to @maxsnew) * Add Dict.filter and Dict.partition (thanks to @hdgarrood) -#### Breaking Changes:+### Breaking Changes: * Revamp Json library, simpler with better names * Revamp JavaScript.Experimental library to have slightly better names * Remove JavaScript library which was made redundant by ports -## 0.12+# 0.12 -#### Breaking Changes:+### Breaking Changes: * Overhaul Graphics.Input library (inspired by Spiros Eliopoulos and Jeff Smitts) * Overhaul Text library to accomodate new Graphics.Input.Field@@ -71,7 +159,7 @@ * Revise the semantics of keepWhen and dropWhen to only update when the filtered signal changes (thanks Max New and Janis Voigtländer) -#### Improvements:+### Improvements: * Add Graphics.Input.Field for customizable text fields * Add Trampoline library (thanks to @maxsnew and @timthelion) @@ -82,12 +170,12 @@ * Fix bugs in Bitwise library * Fix bug when exporting Maybe values through ports -## 0.11+# 0.11 * Ports, a new FFI that is more general and much nicer to use * Basic compiler tests (thanks to Max New) -## 0.10.1+# 0.10.1 * sort, sortBy, sortWith (thanks to Max Goldstein) * elm-repl@@ -95,7 +183,7 @@ * Regex library * Improve Transform2D library (thanks to Michael Søndergaard) -## 0.10+# 0.10 * Native strings * Tango colors@@ -109,7 +197,7 @@ * Make compatable with cabal-1.18 (thank you Justin Leitgeb) * All functions with 10+ arguments (thanks to Max New) -## 0.9.1+# 0.9.1 * Allow custom precedence and associativity for user-defined infix ops * Realias types before printing@@ -119,7 +207,7 @@ * Fix miscellaneous bugs in type checker * Switch name of Matrix2D to Transform2D -## 0.9+# 0.9 Build Improvements: * Major speed improvements to type-checker@@ -170,7 +258,7 @@ forgot to fill this in again... -## 0.7.2+# 0.7.2 * Add a WebSockets library. * Add support for the mathematical looking operator for function composition (U+2218).@@ -179,7 +267,7 @@ forgot to fill this in for a while... -## 0.5.0+# 0.5.0 * Add Dict, Set, and Automaton libraries! @@ -207,7 +295,7 @@ -## 0.4.0+# 0.4.0 This version is all about graphics: nicer API with more features and major efficiency improvements. I am really excited about this release!@@ -237,7 +325,7 @@ -## 0.3.6+# 0.3.6 * Add JSON library. @@ -269,7 +357,7 @@ -## 0.3.5+# 0.3.5 * Add JavaScript event interface. Allows Elm to import and export JS values and events. This makes it possible to import and export Elements, so users@@ -316,10 +404,9 @@ -## 0.3.0+# 0.3.0 -Major Changes (Read this part!)--------------------------------+### Major Changes (Read this part!) * Add a basic module system. * Elm's JavaScript runtime is now distributed with the elm package.@@ -333,8 +420,7 @@ * Improve error messages for parse errors and runtime errors. -New Functions and Other Additions----------------------------------+### New Functions and Other Additions * Add support for keyboard events: Keyboard.Raw * Add buttons in Signal.Input:
elm-compiler.cabal view
@@ -1,6 +1,6 @@ Name: elm-compiler-Version: 0.14.1+Version: 0.15 Synopsis: Values to help with elm-package, elm-make, and elm-lang.org.@@ -64,12 +64,13 @@ Elm.Compiler.Version, Generate.JavaScript, Generate.JavaScript.Helpers,- Generate.JavaScript.Ports,+ Generate.JavaScript.Port, Generate.JavaScript.Variable, Generate.Cases, Transform.AddDefaultImports, Transform.Canonicalize, Transform.Canonicalize.Environment,+ Transform.Canonicalize.Port, Transform.Canonicalize.Setup, Transform.Canonicalize.Type, Transform.Canonicalize.Variable,@@ -115,9 +116,10 @@ cmdargs >= 0.7 && < 0.11, containers >= 0.3 && < 0.6, directory >= 1.0 && < 2.0,+ edit-distance >= 0.2 && < 0.3, filepath >= 1 && < 2.0, indents >= 0.3 && < 0.4,- language-ecmascript >=0.15 && < 0.17,+ language-ecmascript >= 0.15 && < 0.18, language-glsl >= 0.0.2 && < 0.2, mtl >= 2 && < 3, parsec >= 3.1.1 && < 3.5,@@ -181,6 +183,40 @@ union-find >= 0.2 && < 0.3 +Executable elm+ ghc-options:+ -threaded -O2 -W++ Hs-Source-Dirs:+ src++ Main-is:+ CommandLineRouter.hs++ other-modules:+ Elm.Compiler.Version++ Build-depends:+ aeson >= 0.7 && < 0.9,+ aeson-pretty >= 0.7 && < 0.8,+ base >=4.2 && <5,+ binary >= 0.7.0.0 && < 0.8,+ bytestring >= 0.9 && < 0.11,+ cmdargs >= 0.7 && < 0.11,+ containers >= 0.3 && < 0.6,+ directory >= 1.0 && < 2.0,+ filepath >= 1 && < 2.0,+ indents >= 0.3 && < 0.4,+ language-glsl >= 0.0.2 && < 0.2,+ mtl >= 2 && < 3,+ parsec >= 3.1.1 && < 3.5,+ pretty >= 1.0 && < 2.0,+ process,+ text >= 1 && < 2,+ transformers >= 0.2 && < 0.5,+ union-find >= 0.2 && < 0.3++ Test-Suite compiler-tests Type: exitcode-stdio-1.0@@ -215,11 +251,12 @@ cmdargs >= 0.7 && < 0.11, containers >= 0.3 && < 0.6, directory >= 1.0 && < 2.0,+ edit-distance >= 0.2 && < 0.3, elm-compiler, filemanip >= 0.3.5 && < 0.4, filepath >= 1 && < 2.0, indents >= 0.3 && < 0.4,- language-ecmascript >=0.15 && < 0.17,+ language-ecmascript >= 0.15 && < 0.18, language-glsl >= 0.0.2 && < 0.2, mtl >= 2 && < 3, parsec >= 3.1.1 && < 3.5,
src/AST/Declaration.hs view
@@ -2,6 +2,7 @@ module AST.Declaration where import Data.Binary+import qualified AST.Expression.General as General import qualified AST.Expression.Source as Source import qualified AST.Expression.Valid as Valid import qualified AST.Expression.Canonical as Canonical@@ -11,8 +12,9 @@ import Text.PrettyPrint as P +-- DECLARATIONS -data Declaration' port def var+data Declaration' port def var expr = Definition def | Datatype String [String] [(String, [T.Type var])] | TypeAlias String [String] (T.Type var)@@ -24,38 +26,43 @@ deriving (Eq) -data RawPort- = PPAnnotation String T.RawType- | PPDef String Source.Expr+-- DECLARATION PHASES +type SourceDecl =+ Declaration' SourcePort Source.Def Var.Raw Source.Expr -data Port expr var- = Out String expr (T.Type var)- | In String (T.Type var) +type ValidDecl =+ Declaration' ValidPort Valid.Def Var.Raw Valid.Expr -type SourceDecl = Declaration' RawPort Source.Def Var.Raw-type ValidDecl = Declaration' (Port Valid.Expr Var.Raw) Valid.Def Var.Raw-type CanonicalDecl = Declaration' (Port Canonical.Expr Var.Canonical)- Canonical.Def- Var.Canonical +type CanonicalDecl =+ Declaration' CanonicalPort Canonical.Def Var.Canonical Canonical.Expr -portName :: Port expr var -> String-portName port =- case port of- Out name _ _ -> name- In name _ -> name +-- PORTS -assocToString :: Assoc -> String-assocToString assoc =- case assoc of- L -> "left"- N -> "non"- R -> "right"+data SourcePort+ = PortAnnotation String T.RawType+ | PortDefinition String Source.Expr +data ValidPort+ = In String T.RawType+ | Out String Valid.Expr T.RawType+++newtype CanonicalPort+ = CanonicalPort (General.PortImpl Canonical.Expr Var.Canonical)+++validPortName :: ValidPort -> String+validPortName port =+ case port of+ In name _ -> name+ Out name _ _ -> name++ -- BINARY CONVERSION instance Binary Assoc where@@ -77,8 +84,16 @@ -- PRETTY STRINGS -instance (Pretty port, Pretty def, Pretty var, Var.ToString var) =>- Pretty (Declaration' port def var) where+assocToString :: Assoc -> String+assocToString assoc =+ case assoc of+ L -> "left"+ N -> "non"+ R -> "right"+++instance (Pretty port, Pretty def, Pretty var, Var.ToString var, Pretty expr) =>+ Pretty (Declaration' port def var expr) where pretty decl = case decl of Definition def -> pretty def@@ -104,7 +119,8 @@ name' = P.text name <+> P.hsep (map P.text tvars) - Port port -> pretty port+ Port port ->+ pretty port Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op@@ -116,29 +132,53 @@ R -> P.text "r" -instance Pretty RawPort where+instance Pretty SourcePort where pretty port = case port of- PPAnnotation name tipe ->- prettyPort name ":" tipe+ PortAnnotation name tipe ->+ prettyPortType name tipe - PPDef name expr ->- prettyPort name "=" expr+ PortDefinition name expr ->+ prettyPortDef name expr -instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Port expr var) where+instance Pretty ValidPort where pretty port = case port of In name tipe ->- prettyPort name ":" tipe+ prettyPortType name tipe Out name expr tipe ->- P.vcat- [ prettyPort name ":" tipe- , prettyPort name "=" expr- ]- + prettyPort name expr tipe -prettyPort :: (Pretty a) => String -> String -> a -> Doc-prettyPort name op e =- P.text "port" <+> P.text name <+> P.text op <+> pretty e++instance Pretty CanonicalPort where+ pretty (CanonicalPort impl) =+ case impl of+ General.In name tipe ->+ prettyPortType name tipe++ General.Out name expr tipe ->+ prettyPort name expr tipe++ General.Task name expr tipe ->+ prettyPort name expr tipe++++prettyPort :: (Pretty expr, Pretty tipe) => String -> expr -> tipe -> P.Doc+prettyPort name expr tipe =+ P.vcat+ [ prettyPortType name tipe+ , prettyPortDef name expr+ ]+++prettyPortType :: (Pretty tipe) => String -> tipe -> P.Doc+prettyPortType name tipe =+ P.text "port" <+> P.text name <+> P.colon <+> pretty tipe+++prettyPortDef :: (Pretty expr) => String -> expr -> P.Doc+prettyPortDef name expr =+ P.hang (P.text "port" <+> P.text name <+> P.equals) 4 (pretty expr)
src/AST/Expression/Canonical.hs view
@@ -14,17 +14,29 @@ {-| Canonicalized expressions. All variables are fully resolved to the module they came from. -}-type Expr = General.Expr Annotation.Region Def Var.Canonical-type Expr' = General.Expr' Annotation.Region Def Var.Canonical+type Expr =+ General.Expr Annotation.Region Def Var.Canonical ++type Expr' =+ General.Expr' Annotation.Region Def Var.Canonical++ data Def = Definition Pattern.CanonicalPattern Expr (Maybe CanonicalType) deriving (Show) + instance Pretty Def where pretty (Definition pattern expr maybeTipe) = P.vcat [ annotation, definition ]- where- definition = pretty pattern <+> P.equals <+> pretty expr- annotation = case maybeTipe of- Nothing -> P.empty- Just tipe -> pretty pattern <+> P.colon <+> pretty tipe+ where+ definition =+ pretty pattern <+> P.equals <+> pretty expr++ annotation =+ case maybeTipe of+ Nothing ->+ P.empty++ Just tipe ->+ pretty pattern <+> P.colon <+> pretty tipe
src/AST/Expression/General.hs view
@@ -10,14 +10,15 @@ import AST.PrettyPrint import Text.PrettyPrint as P-import AST.Type (Type) import qualified AST.Annotation as Annotation import qualified AST.Helpers as Help import qualified AST.Literal as Literal import qualified AST.Pattern as Pattern+import qualified AST.Type as Type import qualified AST.Variable as Var + ---- GENERAL AST ---- {-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has@@ -38,6 +39,7 @@ type Expr annotation definition variable = Annotation.Annotated annotation (Expr' annotation definition variable) + data Expr' ann def var = Literal Literal.Literal | Var var@@ -56,133 +58,166 @@ | Modify (Expr ann def var) [(String, Expr ann def var)] | Record [(String, Expr ann def var)] -- for type checking and code gen only- | PortIn String (Type var)- | PortOut String (Type var) (Expr ann def var)+ | Port (PortImpl (Expr ann def var) var) | GLShader String String Literal.GLShaderTipe deriving (Show) +-- PORTS++data PortImpl expr var+ = In String (Type.PortType var)+ | Out String expr (Type.PortType var)+ | Task String expr (Type.PortType var)+ deriving (Show)+++portName :: PortImpl expr var -> String+portName impl =+ case impl of+ In name _ -> name+ Out name _ _ -> name+ Task name _ _ -> name++ ---- UTILITIES ---- rawVar :: String -> Expr' ann def Var.Raw-rawVar x = Var (Var.Raw x)+rawVar x =+ Var (Var.Raw x) + localVar :: String -> Expr' ann def Var.Canonical-localVar x = Var (Var.Canonical Var.Local x)+localVar x =+ Var (Var.Canonical Var.Local x) + tuple :: [Expr ann def var] -> Expr' ann def var-tuple es = Data ("_Tuple" ++ show (length es)) es+tuple expressions =+ Data ("_Tuple" ++ show (length expressions)) expressions -delist :: Expr ann def var -> [Expr ann def var]-delist (Annotation.A _ (Data "::" [h,t])) = h : delist t-delist _ = [] saveEnvName :: String-saveEnvName = "_save_the_environment!!!"+saveEnvName =+ "_save_the_environment!!!" + dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical-dummyLet defs = - Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))+dummyLet defs =+ Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName)) + instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where- pretty expr =- case expr of- Literal lit ->- pretty lit+ pretty expression =+ case expression of+ Literal literal ->+ pretty literal Var x -> pretty x - Range e1 e2 ->- P.brackets (pretty e1 <> P.text ".." <> pretty e2)+ Range lowExpr highExpr ->+ P.brackets (pretty lowExpr <> P.text ".." <> pretty highExpr) - ExplicitList es ->- P.brackets (commaCat (map pretty es))+ ExplicitList elements ->+ P.brackets (commaCat (map pretty elements)) - Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) e+ Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) expr | Var.toString op == "-" ->- P.text "-" <> prettyParens e+ P.text "-" <> prettyParens expr - Binop op e1 e2 ->- P.hang (prettyParens e1) 2 (P.text op'' <+> prettyParens e2)+ Binop op leftExpr rightExpr ->+ P.hang (prettyParens leftExpr) 2 (P.text op'' <+> prettyParens rightExpr) where op' = Var.toString op op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`" - Lambda p e ->+ Lambda pattern expr -> P.text "\\" <> args <+> P.text "->" <+> pretty body where- (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)- args = P.sep (map Pattern.prettyParens ps)+ (patterns, body) = collectLambdas expr+ args = P.sep (map Pattern.prettyParens (pattern : patterns)) - App _ _ ->+ App expr arg -> P.hang func 2 (P.sep args) where func:args =- map prettyParens (collectApps (Annotation.A undefined expr))+ map prettyParens (collectApps expr ++ [arg]) MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches) where iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e) - Let defs e ->+ Let defs body -> P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))- , P.text "in" <+> pretty e+ , P.text "in" <+> pretty body ] - Case e pats ->- P.hang pexpr 2 (P.vcat (map pretty' pats))+ Case expr branches ->+ P.hang pexpr 2 (P.vcat (map pretty' branches)) where- pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]- pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b+ pexpr = P.sep [ P.text "case" <+> pretty expr, P.text "of" ]+ pretty' (pattern, branch) =+ pretty pattern <+> P.text "->" <+> pretty branch - Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl- Data "[]" [] -> P.text "[]"- Data name es- | Help.isTuple name -> P.parens (commaCat (map pretty es))- | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))+ Data "::" [hd,tl] ->+ pretty hd <+> P.text "::" <+> pretty tl - Access e x ->- prettyParens e <> P.text "." <> variable x+ Data "[]" [] ->+ P.text "[]" - Remove e x ->- P.braces (pretty e <+> P.text "-" <+> variable x)+ Data name exprs+ | Help.isTuple name ->+ P.parens (commaCat (map pretty exprs))+ | otherwise ->+ P.hang (P.text name) 2 (P.sep (map prettyParens exprs)) - Insert (Annotation.A _ (Remove e y)) x v ->+ Access record field ->+ prettyParens record <> P.text "." <> variable field++ Remove record field ->+ P.braces (pretty record <+> P.text "-" <+> variable field)++ Insert (Annotation.A _ (Remove record y)) x v -> P.braces $ P.hsep- [ pretty e, P.text "-", variable y, P.text "|"+ [ pretty record, P.text "-", variable y, P.text "|" , variable x, P.equals, pretty v ] - Insert e x v ->- P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)+ Insert record field expr ->+ P.braces (pretty record <+> P.text "|" <+> variable field <+> P.equals <+> pretty expr) - Modify e fs ->+ Modify record fields -> P.braces $ P.hang- (pretty e <+> P.text "|")+ (pretty record <+> P.text "|") 4- (commaSep $ map field fs)+ (commaSep $ map field fields) where field (k,v) = variable k <+> P.text "<-" <+> pretty v - Record fs ->+ Record fields -> P.sep- [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fs))+ [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fields)) , P.rbrace ] where- field (field, value) =- variable field <+> P.equals <+> pretty value+ field (name, expr) =+ variable name <+> P.equals <+> pretty expr - GLShader _ _ _ -> P.text "[glsl| ... |]"+ GLShader _ _ _ ->+ P.text "[glsl| ... |]" - PortIn name _ -> P.text $ "<port:" ++ name ++ ">"+ Port portImpl ->+ pretty portImpl - PortOut _ _ signal -> pretty signal++instance (Pretty expr, Pretty var) => Pretty (PortImpl expr var) where+ pretty impl =+ P.text ("<port:" ++ portName impl ++ ">") collectApps :: Expr ann def var -> [Expr ann def var]
src/AST/Expression/Source.hs view
@@ -15,18 +15,25 @@ annotations and definitions, which is how they appear in source code and how they are parsed. -}-type Expr = General.Expr Annotation.Region Def Var.Raw-type Expr' = General.Expr' Annotation.Region Def Var.Raw+type Expr =+ General.Expr Annotation.Region Def Var.Raw ++type Expr' =+ General.Expr' Annotation.Region Def Var.Raw++ data Def = Definition Pattern.RawPattern Expr | TypeAnnotation String RawType deriving (Show) + instance Pretty Def where pretty def =- case def of- TypeAnnotation name tipe ->- variable name <+> P.colon <+> pretty tipe- Definition pattern expr ->- pretty pattern <+> P.equals <+> pretty expr+ case def of+ TypeAnnotation name tipe ->+ variable name <+> P.colon <+> pretty tipe++ Definition pattern expr ->+ pretty pattern <+> P.equals <+> pretty expr
src/AST/Expression/Valid.hs view
@@ -15,17 +15,29 @@ ports are all paired with definitions in the appropriate order, it collapses them into a Def that is easier to work with in later phases of compilation. -}-type Expr = General.Expr Annotation.Region Def Var.Raw-type Expr' = General.Expr' Annotation.Region Def Var.Raw+type Expr =+ General.Expr Annotation.Region Def Var.Raw ++type Expr' =+ General.Expr' Annotation.Region Def Var.Raw++ data Def = Definition Pattern.RawPattern Expr (Maybe RawType) deriving (Show) + instance Pretty Def where pretty (Definition pattern expr maybeTipe) = P.vcat [ annotation, definition ]- where- definition = pretty pattern <+> P.equals <+> pretty expr- annotation = case maybeTipe of- Nothing -> P.empty- Just tipe -> pretty pattern <+> P.colon <+> pretty tipe+ where+ definition =+ pretty pattern <+> P.equals <+> pretty expr++ annotation =+ case maybeTipe of+ Nothing ->+ P.empty++ Just tipe ->+ pretty pattern <+> P.colon <+> pretty tipe
src/AST/Helpers.hs view
@@ -4,7 +4,8 @@ import qualified Data.Char as Char splitDots :: String -> [String]-splitDots = go []+splitDots variable =+ go [] variable where go vars str = case break (=='.') str of@@ -12,16 +13,17 @@ | otherwise -> go (vars ++ [x]) rest (x,[]) -> vars ++ [x] -brkt :: String -> String-brkt s = "{ " ++ s ++ " }" isTuple :: String -> Bool isTuple name =- take 6 name == "_Tuple" && all Char.isDigit (drop 6 name)+ take 6 name == "_Tuple" && all Char.isDigit (drop 6 name) + isOp :: String -> Bool-isOp = all isSymbol+isOp name =+ all isSymbol name + isSymbol :: Char -> Bool isSymbol c =- Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"+ Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
src/AST/Module.hs view
@@ -1,4 +1,14 @@-module AST.Module where+module AST.Module+ ( Interfaces+ , Types, Aliases, ADTs+ , AdtInfo, CanonicalAdt+ , SourceModule, ValidModule, CanonicalModule+ , Module(..), CanonicalBody(..)+ , HeaderAndImports(..)+ , Name, nameToString, nameIsNative+ , Interface(..), toInterface+ , ImportMethod(..)+ ) where import Data.Binary import qualified Data.List as List@@ -65,11 +75,15 @@ , _imports :: [(Name, ImportMethod)] } + type Name = [String] -- must be non-empty + nameToString :: Name -> String-nameToString = List.intercalate "."+nameToString =+ List.intercalate "." + nameIsNative :: Name -> Bool nameIsNative name = case name of@@ -121,27 +135,19 @@ -- IMPORT METHOD -data ImportMethod- = As !String- | Open !(Var.Listing Var.Value)+data ImportMethod = ImportMethod+ { alias :: Maybe String+ , exposedVars :: !(Var.Listing Var.Value)+ } -open :: ImportMethod-open = Open (Var.openListing) -importing :: [Var.Value] -> ImportMethod-importing xs = Open (Var.Listing xs False)- instance Binary ImportMethod where- put method =- case method of- As alias -> putWord8 0 >> put alias- Open listing -> putWord8 1 >> put listing+ put (ImportMethod alias exposedVars) =+ do put alias+ put exposedVars - get = do tag <- getWord8- case tag of- 0 -> As <$> get- 1 -> Open <$> get- _ -> error "Error reading valid ImportMethod type from serialized string"+ get =+ ImportMethod <$> get <*> get -- PRETTY PRINTING@@ -149,20 +155,31 @@ instance (Pretty exs, Pretty body) => Pretty (Module exs body) where pretty (Module names _ exs ims body) = P.vcat [modul, P.text "", prettyImports, P.text "", pretty body]- where - modul = P.text "module" <+> name <+> pretty exs <+> P.text "where"- name = P.text (List.intercalate "." names)+ where+ modul =+ P.text "module" <+> name <+> pretty exs <+> P.text "where" + name =+ P.text (nameToString names)+ prettyImports =- P.vcat $ map prettyMethod ims+ P.vcat $ map prettyMethod ims prettyMethod :: (Name, ImportMethod) -> Doc-prettyMethod import' =- case import' of- ([name], As alias)- | name == alias -> P.empty-- (_, As alias) -> P.text "as" <+> P.text alias+prettyMethod (name, ImportMethod maybeAlias exposedVars) =+ let prettyAlias =+ case maybeAlias of+ Nothing -> P.empty+ Just alias ->+ P.text "as" <+> P.text alias - (_, Open listing) -> pretty listing+ prettyExposed =+ if exposedVars == Var.closedListing+ then P.empty+ else P.text "exposing" <+> pretty exposedVars+ in+ P.text "import"+ <+> P.text (nameToString name)+ <+> prettyAlias+ <+> prettyExposed
src/AST/Pattern.hs view
@@ -9,6 +9,7 @@ import qualified AST.Variable as Var import AST.Literal as Literal + data Pattern var = Data var [Pattern var] | Record [String]@@ -18,55 +19,84 @@ | Literal Literal.Literal deriving (Eq, Ord, Show) -type RawPattern = Pattern Var.Raw-type CanonicalPattern = Pattern Var.Canonical +type RawPattern =+ Pattern Var.Raw+++type CanonicalPattern =+ Pattern Var.Canonical++ cons :: RawPattern -> RawPattern -> RawPattern-cons h t = Data (Var.Raw "::") [h,t]+cons h t =+ Data (Var.Raw "::") [h,t] + nil :: RawPattern-nil = Data (Var.Raw "[]") []+nil =+ Data (Var.Raw "[]") [] + list :: [RawPattern] -> RawPattern-list = foldr cons nil+list patterns =+ foldr cons nil patterns + tuple :: [RawPattern] -> RawPattern-tuple es = Data (Var.Raw ("_Tuple" ++ show (length es))) es+tuple patterns =+ Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns + boundVarList :: Pattern var -> [String]-boundVarList = Set.toList . boundVars+boundVarList pattern =+ Set.toList (boundVars pattern) + boundVars :: Pattern var -> Set.Set String boundVars pattern =- case pattern of- Var x -> Set.singleton x- Alias x p -> Set.insert x (boundVars p)- Data _ ps -> Set.unions (map boundVars ps)- Record fields -> Set.fromList fields- Anything -> Set.empty- Literal _ -> Set.empty+ case pattern of+ Var x -> Set.singleton x+ Alias x p -> Set.insert x (boundVars p)+ Data _ ps -> Set.unions (map boundVars ps)+ Record fields -> Set.fromList fields+ Anything -> Set.empty+ Literal _ -> Set.empty instance Var.ToString var => Pretty (Pattern var) where pretty pattern =- case pattern of- Var x -> variable x- Literal lit -> pretty lit- Record fs -> PP.braces (commaCat $ map variable fs)- Alias x p -> prettyParens p <+> PP.text "as" <+> variable x- Anything -> PP.text "_"- Data name [hd,tl] | Var.toString name == "::" ->- parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl- where- isCons = case hd of- Data ctor _ -> Var.toString ctor == "::"- _ -> False+ case pattern of+ Var x ->+ variable x - Data name ps- | Help.isTuple name' -> PP.parens . commaCat $ map pretty ps- | otherwise -> hsep (PP.text name' : map prettyParens ps)- where- name' = Var.toString name+ Literal literal ->+ pretty literal++ Record fields ->+ PP.braces (commaCat (map variable fields))++ Alias x p ->+ prettyParens p <+> PP.text "as" <+> variable x++ Anything ->+ PP.text "_"++ Data name [hd,tl] | Var.toString name == "::" ->+ parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl+ where+ isCons =+ case hd of+ Data ctor _ -> Var.toString ctor == "::"+ _ -> False+ + Data name ps ->+ let name' = Var.toString name+ in+ if Help.isTuple name'+ then PP.parens (commaCat (map pretty ps))+ else hsep (PP.text name' : map prettyParens ps)+ prettyParens :: Var.ToString var => Pattern var -> Doc prettyParens pattern =
src/AST/PrettyPrint.hs view
@@ -5,28 +5,44 @@ import Text.PrettyPrint as P import qualified AST.Helpers as Help + class Pretty a where pretty :: a -> Doc + instance Pretty Doc where pretty doc = doc + instance Pretty String where pretty = P.text + renderPretty :: (Pretty a) => a -> String-renderPretty e = render (pretty e)+renderPretty e =+ render (pretty e) -commaCat docs = cat (punctuate comma docs)-commaSep docs = sep (punctuate comma docs) +commaCat :: [Doc] -> Doc+commaCat docs =+ cat (punctuate comma docs)+++commaSep :: [Doc] -> Doc+commaSep docs =+ sep (punctuate comma docs)++ parensIf :: Bool -> Doc -> Doc-parensIf bool doc = if bool then parens doc else doc+parensIf bool doc =+ if bool then parens doc else doc + variable :: String -> Doc variable x =- if Help.isOp x then parens (text x) else text x+ if Help.isOp x then parens (text x) else text x + eightyCharLines :: Int -> String -> String eightyCharLines indent message = answer where@@ -38,9 +54,11 @@ | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ") | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ") + instance Error Doc where noMsg = P.empty strMsg = P.text+ instance ErrorList Doc where listMsg str = [ P.text str ]
src/AST/Type.hs view
@@ -1,6 +1,15 @@-module AST.Type where+module AST.Type+ ( Type(..), AliasType(..)+ , RawType, CanonicalType+ , PortType(..), portType+ , fieldMap, recordOf, listOf, tupleOf+ , deepDealias, dealias+ , collectLambdas+ , prettyParens+ ) where import Control.Applicative ((<$>), (<*>))+import Control.Arrow (second) import Data.Binary import qualified Data.Map as Map @@ -9,56 +18,168 @@ import qualified AST.Helpers as Help import Text.PrettyPrint as P ++-- DEFINITION+ data Type var = Lambda (Type var) (Type var) | Var String | Type var | App (Type var) [Type var] | Record [(String, Type var)] (Maybe (Type var))- | Aliased Var.Canonical (Type var)- deriving (Eq,Show)+ | Aliased Var.Canonical [(String, Type var)] (AliasType var)+ deriving (Eq, Ord, Show) -type RawType = Type Var.Raw-type CanonicalType = Type Var.Canonical +data AliasType var+ = Holey (Type var)+ | Filled (Type var)+ deriving (Eq, Ord, Show)+++type RawType =+ Type Var.Raw+++type CanonicalType =+ Type Var.Canonical+++data PortType var+ = Normal (Type var)+ | Signal { root :: Type var, arg :: Type var }+ deriving (Show)+++portType :: PortType var -> Type var+portType portType =+ case portType of+ Normal tipe -> tipe+ Signal tipe _ -> tipe++ fieldMap :: [(String,a)] -> Map.Map String [a] fieldMap fields =- foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields+ let add r (field,tipe) =+ Map.insertWith (++) field [tipe] r+ in+ foldl add Map.empty fields + recordOf :: [(String, Type var)] -> Type var-recordOf fields = Record fields Nothing+recordOf fields =+ Record fields Nothing + listOf :: RawType -> RawType-listOf t = App (Type (Var.Raw "List")) [t]+listOf tipe =+ App (Type (Var.Raw "List")) [tipe] + tupleOf :: [RawType] -> RawType-tupleOf ts = App (Type t) ts- where- t = Var.Raw ("_Tuple" ++ show (length ts))+tupleOf types =+ let name = Var.Raw ("_Tuple" ++ show (length types))+ in+ App (Type name) types ++-- DEALIASING++deepDealias :: Type v -> Type v+deepDealias tipe =+ let go = deepDealias in+ case tipe of+ Lambda a b ->+ Lambda (go a) (go b)++ Var _ ->+ tipe++ Record fields ext ->+ Record (map (second go) fields) (fmap go ext)++ Aliased _name args tipe' ->+ deepDealias (dealias args tipe')++ Type _ ->+ tipe++ App f args ->+ App (go f) (map go args)+++dealias :: [(String, Type v)] -> AliasType v -> Type v+dealias args aliasType =+ case aliasType of+ Holey tipe ->+ dealiasHelp (Map.fromList args) tipe++ Filled tipe ->+ tipe+++dealiasHelp :: Map.Map String (Type var) -> Type var -> Type var+dealiasHelp typeTable tipe =+ let go = dealiasHelp typeTable in+ case tipe of+ Lambda a b ->+ Lambda (go a) (go b)++ Var x ->+ Map.findWithDefault tipe x typeTable++ Record fields ext ->+ Record (map (second go) fields) (fmap go ext)++ Aliased original args t' ->+ Aliased original (map (second go) args) t'++ Type _ ->+ tipe++ App f args ->+ App (go f) (map go args)+++-- PRETTY PRINTING++instance (Pretty var, Var.ToString var) => Pretty (PortType var) where+ pretty portType =+ case portType of+ Normal tipe ->+ pretty tipe++ Signal tipe _ ->+ pretty tipe++ instance (Var.ToString var, Pretty var) => Pretty (Type var) where pretty tipe = case tipe of- Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]+ Lambda _ _ ->+ P.sep [ t, P.sep (map (P.text "->" <+>) ts) ] where t:ts = map prettyLambda (collectLambdas tipe)- prettyLambda t = case t of- Lambda _ _ -> P.parens (pretty t)- _ -> pretty t+ prettyLambda t =+ case t of+ Lambda _ _ -> P.parens (pretty t)+ _ -> pretty t - Var x -> P.text x+ Var x ->+ P.text x Type var ->- let v = Var.toString var in- P.text (if v == "_Tuple0" then "()" else v)+ let v = Var.toString var+ in+ P.text (if v == "_Tuple0" then "()" else v) App f args -> case (f,args) of (Type name, _) | Help.isTuple (Var.toString name) ->- P.parens . P.sep . P.punctuate P.comma $ map pretty args+ P.parens (P.sep (P.punctuate P.comma (map pretty args))) - _ -> P.hang (pretty f) 2 (P.sep $ map prettyParens args)+ _ -> P.hang (pretty f) 2 (P.sep (map prettyParens args)) Record _ _ -> case flattenRecord tipe of@@ -83,59 +204,87 @@ prettyField (field, tipe) = P.text field <+> P.text ":" <+> pretty tipe - Aliased name t ->- let t' = pretty t in- if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]- then t'- else pretty name+ Aliased name args _ ->+ P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args)) collectLambdas :: Type var -> [Type var] collectLambdas tipe = case tipe of- Lambda arg body -> arg : collectLambdas body- _ -> [tipe]+ Lambda arg body ->+ arg : collectLambdas body + _ ->+ [tipe]++ prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc-prettyParens tipe = parensIf (needed tipe) (pretty tipe)+prettyParens tipe =+ parensIf (needed tipe) (pretty tipe) where needed t = case t of- Aliased _ t' -> needed t'+ Aliased _ [] _ -> False + Aliased _ _ _ -> True+ Lambda _ _ -> True - App (Type name) _ | Help.isTuple (Var.toString name) -> False+ App (Type name) _+ | Help.isTuple (Var.toString name) ->+ False+ App t' [] -> needed t'+ App _ _ -> True _ -> False + flattenRecord :: Type var -> ( [(String, Type var)], Maybe String ) flattenRecord tipe =- case tipe of- Var x -> ([], Just x)+ case tipe of+ Var x ->+ ([], Just x) - Record fields Nothing -> (fields, Nothing)+ Record fields Nothing ->+ (fields, Nothing) - Record fields (Just ext) ->- let (fields',ext') = flattenRecord ext- in (fields' ++ fields, ext')+ Record fields (Just ext) ->+ let (fields',ext') = flattenRecord ext+ in+ (fields' ++ fields, ext') - Aliased _ tipe' -> flattenRecord tipe'+ Aliased _ args tipe' ->+ flattenRecord (dealias args tipe') - _ -> error "Trying to flatten ill-formed record."+ _ ->+ error "Trying to flatten ill-formed record." ++-- BINARY+ instance Binary var => Binary (Type var) where put tipe = case tipe of- Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2- Var x -> putWord8 1 >> put x- Type name -> putWord8 2 >> put name- App t1 t2 -> putWord8 3 >> put t1 >> put t2- Record fs ext -> putWord8 4 >> put fs >> put ext- Aliased var t -> putWord8 5 >> put var >> put t+ Lambda t1 t2 ->+ putWord8 0 >> put t1 >> put t2 + Var x ->+ putWord8 1 >> put x++ Type name ->+ putWord8 2 >> put name++ App t1 t2 ->+ putWord8 3 >> put t1 >> put t2++ Record fs ext ->+ putWord8 4 >> put fs >> put ext++ Aliased var args t ->+ putWord8 5 >> put var >> put args >> put t+ get = do n <- getWord8 case n of@@ -144,5 +293,22 @@ 2 -> Type <$> get 3 -> App <$> get <*> get 4 -> Record <$> get <*> get- 5 -> Aliased <$> get <*> get+ 5 -> Aliased <$> get <*> get <*> get+ _ -> error "Error reading a valid type from serialized string"+++instance Binary var => Binary (AliasType var) where+ put aliasType =+ case aliasType of+ Holey tipe ->+ putWord8 0 >> put tipe++ Filled tipe ->+ putWord8 1 >> put tipe++ get = do+ n <- getWord8+ case n of+ 0 -> Holey <$> get+ 1 -> Filled <$> get _ -> error "Error reading a valid type from serialized string"
src/AST/Variable.hs view
@@ -37,6 +37,11 @@ builtin x = Canonical BuiltIn x +fromModule :: [String] -> String -> Canonical+fromModule home name =+ Canonical (Module home) name++ -- VARIABLE RECOGNIZERS is :: [String] -> String -> Canonical -> Bool@@ -58,6 +63,11 @@ is ["Array"] "Array" +isTask :: Canonical -> Bool+isTask =+ is ["Task"] "Task"++ isSignal :: Canonical -> Bool isSignal = is ["Signal"] "Signal"@@ -101,7 +111,8 @@ instance ToString Raw where- toString (Raw x) = x+ toString (Raw name) =+ name instance ToString Canonical where@@ -126,6 +137,16 @@ Listing [] True +closedListing :: Listing a+closedListing =+ Listing [] False+++listing :: [a] -> Listing a+listing xs =+ Listing xs False++ -- | A value that can be imported or exported data Value = Value !String@@ -178,11 +199,13 @@ -- PRETTY VARIABLES instance Pretty Raw where- pretty (Raw var) = variable var+ pretty (Raw name) =+ variable name instance Pretty Canonical where- pretty var = P.text (toString var)+ pretty var =+ P.text (toString var) instance Pretty a => Pretty (Listing a) where
+ src/CommandLineRouter.hs view
@@ -0,0 +1,73 @@+module Main where++import qualified System.Directory as Dir+import qualified System.Environment as Env+import System.Exit (exitWith)+import System.IO (hPutStrLn, stderr, stdin, stdout)+import qualified System.Process as Proc++import qualified Elm.Compiler.Version as Compiler+++main :: IO ()+main =+ do allArgs <- Env.getArgs+ case allArgs of+ [] ->+ putStrLn usageMessage++ command : args ->+ attemptToRun command args+++attemptToRun :: String -> [String] -> IO ()+attemptToRun command args =+ do found <- Dir.findExecutable ("elm-" ++ command)+ case found of+ Nothing ->+ hPutStrLn stderr $+ "Could not find command '" ++ command ++ "'. Maybe there is a typo?\n\n\+ \Default commands include:\n\n"+ ++ availableCommands +++ "\nWhen you try to run the command '" ++ command ++ "' we actually search for an\n\+ \ executable named elm-" ++ command ++ ". Are you able to run elm-" ++ command ++ "?\n\+ \ Is it on your PATH?"++ Just path ->+ let createProc =+ (Proc.proc path args)+ { Proc.std_in = Proc.UseHandle stdin+ , Proc.std_out = Proc.UseHandle stdout+ , Proc.std_err = Proc.UseHandle stderr+ }+ in+ do (_, _, _, handle) <- Proc.createProcess createProc+ exitWith =<< Proc.waitForProcess handle+++usageMessage :: String+usageMessage =+ "Elm Platform " ++ Compiler.version ++ " - a way to run all Elm tools\n\+ \\n\+ \Usage: elm <command> [<args>]\n\+ \\n\+ \Available commands include:\n\n"+ ++ availableCommands +++ "\nYou can learn more about a specific command by running things like:\n\+ \\n\+ \ elm make --help\n\+ \ elm package --help\n\+ \ elm <command> --help\n\+ \\n\+ \In all these cases we are simply running 'elm-<command>' so if you create an\n\+ \executable named 'elm-foobar' you will be able to run it as 'elm foobar' as\n\+ \long as it appears on your PATH."+++availableCommands :: String+availableCommands =+ " make Compile an Elm file or project into JS or HTML\n\+ \ package Manage packages from <http://package.elm-lang.org>\n\+ \ reactor Develop with compile-on-refresh and time-travel debugging\n\+ \ repl A REPL for running individual expressions\n"+
src/Docs.hs view
@@ -9,6 +9,7 @@ import Control.Applicative ((<$>)) import Control.Arrow (second)+import Control.Monad (when) import qualified Data.Aeson.Encode.Pretty as Json import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Map as Map@@ -54,7 +55,17 @@ main :: IO () main = do flags <- cmdArgs defaultFlags- source <- readFile (input flags)+ let inputFileName = input flags++ exists <- doesFileExist inputFileName+ when (not exists) $+ do hPutStrLn stderr $+ if null inputFileName+ then "Error: you must provide a file to document!"+ else "Error: could not find a file named '" ++ inputFileName ++ "'"+ exitFailure++ source <- readFile inputFileName case Parse.iParse documentation source of Right docs -> let json = Json.encodePretty' config docs in@@ -178,7 +189,9 @@ case decl of Decl.Definition def -> case def of- Source.Definition _ _ -> error errorMessage+ Source.Definition _ _ ->+ error (errorMessage "unannotated definitions")+ Source.TypeAnnotation name tipe -> let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing in@@ -201,13 +214,13 @@ info { infixes = Map.insert name infixInfo (infixes info) } Decl.Port _ ->- error errorMessage+ error (errorMessage "ports") -errorMessage :: String-errorMessage =- "there appears to be a bug in this tool.\n" ++- "Please report it to <https://github.com/elm-lang/Elm/issues>"+errorMessage :: String -> String+errorMessage name =+ "Unable to deal with annotations on " ++ name ++ " at this time.\n" +++ "Please report your use case to <https://github.com/elm-lang/elm-compiler/issues>" -- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS
src/Elm/Compiler.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE FlexibleContexts #-} module Elm.Compiler- ( version+ ( version, rawVersion , parseDependencies, compile ) where @@ -25,6 +25,11 @@ version :: String version = Version.version+++rawVersion :: [Int]+rawVersion =+ Version.rawVersion -- DEPENDENCIES
src/Elm/Compiler/Module.hs view
@@ -34,7 +34,7 @@ defaultImports :: [Name] defaultImports =- map Name (Map.keys Defaults.defaultImports)+ map (Name . fst) Defaults.defaultImports -- POKING AROUND INTERFACES
src/Elm/Compiler/Type.hs view
@@ -67,6 +67,11 @@ (ADT, _ : _) -> P.parens adt _ -> adt + App _ _ ->+ error $+ "Somehow ended up with an unexpected type, please post a minimal example that\n"+ ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"+ Record _ _ -> case flattenRecord tipe of ([], Nothing) ->@@ -137,7 +142,7 @@ , "name" .= Json.toJSON name ] - App t ts -> + App t ts -> [ "tag" .= ("app" :: Text.Text) , "func" .= Json.toJSON t , "args" .= Json.toJSON ts
src/Elm/Compiler/Type/Extract.hs view
@@ -26,5 +26,5 @@ Type.Record fields ext -> T.Record (map (second fromInternalType) fields) (fmap fromInternalType ext) - Type.Aliased _ t ->- fromInternalType t+ Type.Aliased _name args t ->+ fromInternalType (Type.dealias args t)
src/Elm/Compiler/Version.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wall #-}-module Elm.Compiler.Version (version) where+module Elm.Compiler.Version (version, rawVersion) where import qualified Data.Version as Version import qualified Paths_elm_compiler as This@@ -8,3 +8,8 @@ version :: String version = Version.showVersion This.version+++rawVersion :: [Int]+rawVersion =+ Version.versionBranch This.version
src/Elm/Utils.hs view
@@ -51,12 +51,12 @@ where context msg = "failure when running:" ++ concatMap (' ':) (command:args) ++ "\n" ++ msg- + message err = case err of CommandFailed stderr stdout -> stdout ++ stderr- MissingExe msg -> + MissingExe msg -> msg
src/Generate/JavaScript.hs view
@@ -11,16 +11,16 @@ import Generate.JavaScript.Helpers as Help import qualified Generate.Cases as Case-import qualified Generate.JavaScript.Ports as Port+import qualified Generate.JavaScript.Port as Port import qualified Generate.JavaScript.Variable as Var import AST.Annotation import AST.Module import AST.Expression.General import qualified AST.Expression.Canonical as Canonical-import qualified AST.Module as Module import qualified AST.Helpers as Help import AST.Literal+import qualified AST.Module as Module import qualified AST.Pattern as P import qualified AST.Variable as Var @@ -30,13 +30,12 @@ [ varDecl "_N" (obj ["Elm","Native"]) , include "_U" "Utils" , include "_L" "List"- , include "_P" "Ports" , varDecl Help.localModuleName (string (Module.nameToString name)) ]- where- include :: String -> String -> VarDecl ()- include alias modul =- varDecl alias (Help.make ["_N", modul])+ where+ include :: String -> String -> VarDecl ()+ include alias modul =+ varDecl alias (Help.make ["_N", modul]) _Utils :: String -> Expression ()@@ -62,46 +61,48 @@ expression :: Canonical.Expr -> State Int (Expression ()) expression (A region expr) = case expr of- Var var -> return $ Var.canonical var+ Var var ->+ return $ Var.canonical var - Literal lit -> return $ literal lit+ Literal lit ->+ return $ literal lit Range lo hi ->- do lo' <- expression lo- hi' <- expression hi- return $ _List "range" `call` [lo',hi']+ do lo' <- expression lo+ hi' <- expression hi+ return $ _List "range" `call` [lo',hi'] Access e field ->- do e' <- expression e- return $ DotRef () e' (var (Var.varName field))+ do e' <- expression e+ return $ DotRef () e' (var (Var.varName field)) Remove e field ->- do e' <- expression e- return $ _Utils "remove" `call` [ string (Var.varName field), e' ]+ do e' <- expression e+ return $ _Utils "remove" `call` [ string (Var.varName field), e' ] Insert e field value ->- do value' <- expression value- e' <- expression e- return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]+ do value' <- expression value+ e' <- expression e+ return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ] Modify e fields ->- do e' <- expression e- fields' <-+ do e' <- expression e+ fields' <- forM fields $ \(field, value) -> do value' <- expression value return $ ArrayLit () [ string (Var.varName field), value' ] - return $ _Utils "replace" `call` [ArrayLit () fields', e']+ return $ _Utils "replace" `call` [ArrayLit () fields', e'] Record fields ->- do fields' <-+ do fields' <- forM fields $ \(field, e) -> (,) (Var.varName field) <$> expression e - let fieldMap =+ let fieldMap = List.foldl' combine Map.empty fields' - return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap+ return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap where combine record (field, value) = Map.insertWith (++) field [value] record@@ -113,21 +114,26 @@ visible fs = map (first prop) (Map.toList (Map.map head fs)) - Binop op e1 e2 -> binop region op e1 e2+ Binop op e1 e2 ->+ binop region op e1 e2 Lambda p e@(A ann _) ->- do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)- body' <- expression body- return $ case length args < 2 || length args > 9 of- True -> foldr (==>) body' (map (:[]) args)- False -> ref ("F" ++ show (length args)) <| (args ==> body')+ do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)+ body' <- expression body+ return $+ case length args < 2 || length args > 9 of+ True -> foldr (==>) body' (map (:[]) args)+ False -> ref ("F" ++ show (length args)) <| (args ==> body') where depattern (args, body) pattern = case pattern of- P.Var x -> return (args ++ [ Var.varName x ], body)- _ -> do arg <- Case.newVar+ P.Var x ->+ return (args ++ [ Var.varName x ], body)+ _ ->+ do arg <- Case.newVar return ( args ++ [arg]- , A ann (Case (A ann (localVar arg)) [(pattern, body)]))+ , A ann (Case (A ann (localVar arg)) [(pattern, body)])+ ) (patterns, innerBody) = collect [p] e @@ -137,12 +143,13 @@ _ -> (patterns, lexpr) App e1 e2 ->- do func' <- expression func- args' <- mapM expression args- return $ case args' of- [arg] -> func' <| arg- _ | length args' <= 9 -> ref aN `call` (func':args')- | otherwise -> foldl1 (<|) (func':args')+ do func' <- expression func+ args' <- mapM expression args+ return $+ case args' of+ [arg] -> func' <| arg+ _ | length args' <= 9 -> ref aN `call` (func':args')+ | otherwise -> foldl1 (<|) (func':args') where aN = "A" ++ show (length args) (func, args) = getArgs e1 [e2]@@ -152,117 +159,127 @@ _ -> (func, args) Let defs e ->- do let (defs',e') = flattenLets defs e - stmts <- concat <$> mapM definition defs'- exp <- expression e'- return $ function [] (stmts ++ [ ret exp ]) `call` []+ do let (defs',e') = flattenLets defs e+ stmts <- concat <$> mapM definition defs'+ exp <- expression e'+ return $ function [] (stmts ++ [ ret exp ]) `call` [] MultiIf branches ->- do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e- return $ case last branches of- (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->- safeIfs branches'- (A _ (Literal (Boolean True)), _) -> safeIfs branches'- _ -> ifs branches' (throw "badIf" region)+ do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e+ return $+ case last branches of+ (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->+ safeIfs branches'+ (A _ (Literal (Boolean True)), _) ->+ safeIfs branches'+ _ ->+ ifs branches' (throw "badIf" region) where safeIfs branches = ifs (init branches) (snd (last branches)) ifs branches finally = foldr iff finally branches iff (if', then') else' = CondExpr () if' then' else' Case e cases ->- do (tempVar,initialMatch) <- Case.toMatch cases- (revisedMatch, stmt) <-- case e of- A _ (Var (Var.Canonical Var.Local x)) ->- return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])- _ ->- do e' <- expression e- return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])- match' <- match region revisedMatch- return (function [] (stmt ++ match') `call` [])+ do (tempVar,initialMatch) <- Case.toMatch cases+ (revisedMatch, stmt) <-+ case e of+ A _ (Var (Var.Canonical Var.Local x)) ->+ return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])+ _ ->+ do e' <- expression e+ return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])+ match' <- match region revisedMatch+ return (function [] (stmt ++ match') `call` []) ExplicitList es ->- do es' <- mapM expression es- return $ _List "fromArray" <| ArrayLit () es'+ do es' <- mapM expression es+ return $ _List "fromArray" <| ArrayLit () es' Data name es ->- do es' <- mapM expression es- return $ ObjectLit () (ctor : fields es')+ do es' <- mapM expression es+ return $ ObjectLit () (ctor : fields es') where ctor = (prop "ctor", string name)- fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]+ fields =+ zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ] GLShader _uid src _tipe ->- return $ ObjectLit () [(PropString () "src", literal (Str src))]- - PortIn name tipe ->- return $ obj ["_P","portIn"] `call`- [ string name, Port.incoming tipe ]+ return $ ObjectLit () [(PropString () "src", literal (Str src))] - PortOut name tipe value ->- do value' <- expression value- return $ obj ["_P","portOut"] `call`- [ string name, Port.outgoing tipe, value' ]+ Port impl ->+ case impl of+ In name portType ->+ return (Port.inbound name portType) + Out name expr portType ->+ do expr' <- expression expr+ return (Port.outbound name expr' portType) + Task name expr portType ->+ do expr' <- expression expr+ return (Port.task name expr' portType)++ definition :: Canonical.Def -> State Int [Statement ()]-definition (Canonical.Definition pattern expr@(A region _) _) = do- expr' <- expression expr- let assign x = varDecl x expr'- case pattern of- P.Var x- | Help.isOp x ->- let op = LBracket () (ref "_op") (string x) in- return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]- | otherwise ->- return [ VarDeclStmt () [ assign (Var.varName x) ] ]+definition (Canonical.Definition pattern expr@(A region _) _) =+ do expr' <- expression expr+ let assign x = varDecl x expr'+ case pattern of+ P.Var x+ | Help.isOp x ->+ let op = LBracket () (ref "_op") (string x) in+ return [ ExprStmt () $ AssignExpr () OpAssign op expr' ] - P.Record fields ->- let setField f = varDecl f (obj ["$",f]) in- return [ VarDeclStmt () (assign "$" : map setField fields) ]+ | otherwise ->+ return [ VarDeclStmt () [ assign (Var.varName x) ] ] - P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->- return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]- where- vars = getVars patterns- getVars patterns =- case patterns of- P.Var x : rest -> (Var.varName x :) `fmap` getVars rest- [] -> Just []- _ -> Nothing+ P.Record fields ->+ let setField f = varDecl f (obj ["$",f]) in+ return [ VarDeclStmt () (assign "$" : map setField fields) ] - decl x n = varDecl x (obj ["$","_" ++ show n])- setup vars- | Help.isTuple name = assign "$" : vars- | otherwise = assign "_raw" : safeAssign : vars+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->+ return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]+ where+ vars = getVars patterns+ getVars patterns =+ case patterns of+ P.Var x : rest -> (Var.varName x :) `fmap` getVars rest+ [] -> Just []+ _ -> Nothing - safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)- if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)- exception = Help.throw "badCase" region+ decl x n = varDecl x (obj ["$","_" ++ show n])+ setup vars+ | Help.isTuple name = assign "$" : vars+ | otherwise = assign "_raw" : safeAssign : vars - _ ->- do defs' <- concat <$> mapM toDef vars- return (VarDeclStmt () [assign "_"] : defs')- where- vars = P.boundVarList pattern- mkVar = A region . localVar- toDef y =- let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]- in- definition $ Canonical.Definition (P.Var y) expr Nothing+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)+ exception = Help.throw "badCase" region + _ ->+ do defs' <- concat <$> mapM toDef vars+ return (VarDeclStmt () [assign "_"] : defs')+ where+ vars = P.boundVarList pattern+ mkVar = A region . localVar+ toDef y =+ let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]+ in+ definition $ Canonical.Definition (P.Var y) expr Nothing + match :: Region -> Case.Match -> State Int [Statement ()] match region mtch = case mtch of Case.Match name clauses mtch' ->- do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses- mtch'' <- match region mtch'- return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')+ do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses+ mtch'' <- match region mtch'+ return (SwitchStmt () (format isChars (access name)) clauses' : mtch'') where- isLiteral p = case p of- Case.Clause (Right _) _ _ -> True- _ -> False+ isLiteral p =+ case p of+ Case.Clause (Right _) _ _ -> True+ _ -> False access name | any isLiteral clauses = obj [name]@@ -275,26 +292,30 @@ Case.Fail -> return [ ExprStmt () (Help.throw "badCase" region) ] - Case.Break -> return [BreakStmt () Nothing]+ Case.Break ->+ return [BreakStmt () Nothing] Case.Other e ->- do e' <- expression e- return [ ret e' ]+ do e' <- expression e+ return [ ret e' ] - Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)- where- dropEnd acc [] = acc- dropEnd acc (m:ms) =- case m of- Case.Other _ -> acc ++ [m]- _ -> dropEnd (acc ++ [m]) ms+ Case.Seq ms ->+ concat <$> mapM (match region) (dropEnd [] ms)+ where+ dropEnd acc [] = acc+ dropEnd acc (m:ms) =+ case m of+ Case.Other _ -> acc ++ [m]+ _ -> dropEnd (acc ++ [m]) ms clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ()) clause region variable (Case.Clause value vars mtch) = (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch) where- vars' = map (\n -> variable ++ "._" ++ show n) [0..]+ vars' =+ map (\n -> variable ++ "._" ++ show n) [0..]+ (isChar, pattern) = case value of Right (Chr c) -> (True, string [c])@@ -314,7 +335,7 @@ _ -> (defs, lexpr) -generate :: CanonicalModule -> String +generate :: CanonicalModule -> String generate modul = show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++ [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]@@ -375,7 +396,7 @@ Var.Union _ (Var.Listing ctors _) -> map Var.varName ctors- + assign path expr = case path of [x] -> VarDeclStmt () [ varDecl x expr ]
+ src/Generate/JavaScript/Port.hs view
@@ -0,0 +1,277 @@+module Generate.JavaScript.Port (inbound, outbound, task) where++import qualified Data.List as List+import Language.ECMAScript3.Syntax++import AST.PrettyPrint (pretty)+import AST.Type as T+import qualified AST.Variable as Var+import Generate.JavaScript.Helpers+++-- TASK++task :: String -> Expression () -> T.PortType var -> Expression ()+task name expr portType =+ case portType of+ T.Normal _ ->+ _Task "perform" `call` [ expr ]++ T.Signal _ _ ->+ _Task "performSignal" `call` [ string name, expr ]++++-- HELPERS++data JSType+ = JSNumber+ | JSBoolean+ | JSString+ | JSArray+ | JSObject [String]+++typeToString :: JSType -> String+typeToString tipe =+ case tipe of+ JSNumber -> "a number"+ JSBoolean -> "a boolean (true or false)"+ JSString -> "a string"+ JSArray -> "an array"+ JSObject fields ->+ "an object with fields '" ++ List.intercalate "', '" fields ++ "'"+++_Array :: String -> Expression ()+_Array functionName =+ useLazy ["Elm","Native","Array"] functionName+++_List :: String -> Expression ()+_List functionName =+ useLazy ["Elm","Native","List"] functionName+++_Maybe :: String -> Expression ()+_Maybe functionName =+ useLazy ["Elm","Maybe"] functionName+++_Port :: String -> Expression ()+_Port functionName =+ useLazy ["Elm","Native","Port"] functionName+++_Task :: String -> Expression ()+_Task functionName =+ useLazy ["Elm","Native","Task"] functionName+++check :: Expression () -> JSType -> Expression () -> Expression ()+check x jsType continue =+ CondExpr () (jsFold OpLOr checks x) continue throw+ where+ jsFold op checks value =+ foldl1 (InfixExpr () op) (map ($ value) checks)++ throw =+ obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]++ checks =+ case jsType of+ JSNumber -> [typeof "number"]+ JSBoolean -> [typeof "boolean"]+ JSString -> [typeof "string", instanceof "String"]+ JSArray -> [instanceof "Array"]+ JSObject fields ->+ [jsFold OpLAnd (typeof "object" : map member fields)]+++-- INBOUND++inbound :: String -> T.PortType Var.Canonical -> Expression ()+inbound name portType =+ case portType of+ T.Normal tipe ->+ _Port "inbound" `call`+ [ string name+ , string (show (pretty tipe))+ , toTypeFunction tipe+ ]++ T.Signal _root arg ->+ _Port "inboundSignal" `call`+ [ string name+ , string (show (pretty arg))+ , toTypeFunction arg+ ]+++toTypeFunction :: CanonicalType -> Expression ()+toTypeFunction tipe =+ ["v"] ==> toType tipe (ref "v")+++toType :: CanonicalType -> Expression () -> Expression ()+toType tipe x =+ case tipe of+ Lambda _ _ ->+ error "functions should not be allowed through input ports"++ Var _ ->+ error "type variables should not be allowed through input ports"++ Aliased _ args t ->+ toType (dealias args t) x++ Type (Var.Canonical Var.BuiltIn name)+ | name == "Int" -> from JSNumber+ | name == "Float" -> from JSNumber+ | name == "Bool" -> from JSBoolean+ | name == "String" -> from JSString+ where+ from checks = check x checks x++ Type name+ | Var.isJson name ->+ x++ | Var.isTuple name ->+ toTuple [] x++ | otherwise ->+ error "bad type got to foreign input conversion"++ App f args ->+ case f : args of+ Type name : [t]+ | Var.isMaybe name ->+ CondExpr ()+ (equal x (NullLit ()))+ (_Maybe "Nothing")+ (_Maybe "Just" <| toType t x)++ | Var.isList name ->+ check x JSArray (_List "fromArray" <| array)++ | Var.isArray name ->+ check x JSArray (_Array "fromJSArray" <| array)+ where+ array = DotRef () x (var "map") <| toTypeFunction t++ Type name : ts+ | Var.isTuple name ->+ toTuple ts x++ _ -> error "bad ADT got to foreign input conversion"++ Record _ (Just _) ->+ error "bad record got to foreign input conversion"++ Record fields Nothing ->+ check x (JSObject (map fst fields)) object+ where+ object = ObjectLit () $ (prop "_", ObjectLit () []) : keys+ keys = map convert fields+ convert (f,t) = (prop f, toType t (DotRef () x (var f)))+++toTuple :: [CanonicalType] -> Expression () -> Expression ()+toTuple types x =+ check x JSArray (ObjectLit () fields)+ where+ fields =+ (prop "ctor", ctor) : zipWith convert [0..] types++ ctor =+ string ("_Tuple" ++ show (length types))++ convert n t =+ ( prop ('_':show n)+ , toType t (BracketRef () x (IntLit () n))+ )+++-- OUTBOUND++outbound :: String -> Expression () -> T.PortType Var.Canonical -> Expression ()+outbound name expr portType =+ case portType of+ T.Normal tipe ->+ _Port "outbound" `call` [ string name, fromTypeFunction tipe, expr ]++ T.Signal _ arg ->+ _Port "outboundSignal" `call` [ string name, fromTypeFunction arg, expr ]+++fromTypeFunction :: CanonicalType -> Expression ()+fromTypeFunction tipe =+ ["v"] ==> fromType tipe (ref "v")+++fromType :: CanonicalType -> Expression () -> Expression ()+fromType tipe x =+ case tipe of+ Aliased _ args t ->+ fromType (dealias args t) x++ Lambda _ _+ | numArgs > 1 && numArgs < 10 ->+ func (ref ('A':show numArgs) `call` (x:values))+ | otherwise ->+ func (foldl (<|) x values)+ where+ ts = T.collectLambdas tipe+ numArgs = length ts - 1+ args = map (\n -> '_' : show n) [0..]+ values = zipWith toType (init ts) (map ref args)+ func body =+ function (take numArgs args)+ [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]+ , ret (fromType (last ts) (ref "_r"))+ ]++ Var _ ->+ error "type variables should not be allowed through outputs"++ Type (Var.Canonical Var.BuiltIn name)+ | name `elem` ["Int","Float","Bool","String"] ->+ x++ Type name+ | Var.isJson name -> x+ | Var.isTuple name -> ArrayLit () []+ | otherwise -> error "bad type got to an output"++ App f args ->+ case f : args of+ Type name : [t]+ | Var.isMaybe name ->+ CondExpr ()+ (equal (DotRef () x (var "ctor")) (string "Nothing"))+ (NullLit ())+ (fromType t (DotRef () x (var "_0")))++ | Var.isArray name ->+ DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t++ | Var.isList name ->+ DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t++ Type name : ts+ | Var.isTuple name ->+ let convert n t = fromType t $ DotRef () x $ var ('_':show n)+ in ArrayLit () $ zipWith convert [0..] ts++ _ -> error "bad ADT got to an output"++ Record _ (Just _) ->+ error "bad record got to an output"++ Record fields Nothing ->+ ObjectLit () keys+ where+ keys = map convert fields+ convert (f,t) =+ (PropId () (var f), fromType t (DotRef () x (var f)))
− src/Generate/JavaScript/Ports.hs
@@ -1,217 +0,0 @@-module Generate.JavaScript.Ports (incoming, outgoing) where--import qualified Data.List as List-import Generate.JavaScript.Helpers-import AST.Type as T-import qualified AST.Variable as Var-import Language.ECMAScript3.Syntax---data JSType- = JSNumber- | JSBoolean- | JSString- | JSArray- | JSObject [String]---typeToString :: JSType -> String-typeToString tipe =- case tipe of- JSNumber -> "a number"- JSBoolean -> "a boolean (true or false)"- JSString -> "a string"- JSArray -> "an array"- JSObject fields ->- "an object with fields '" ++ List.intercalate "', '" fields ++ "'"---_Array :: String -> Expression ()-_Array functionName =- useLazy ["Elm","Native","Array"] functionName---_List :: String -> Expression ()-_List functionName =- useLazy ["Elm","Native","List"] functionName---_Maybe :: String -> Expression ()-_Maybe functionName =- useLazy ["Elm","Maybe"] functionName---check :: Expression () -> JSType -> Expression () -> Expression ()-check x jsType continue =- CondExpr () (jsFold OpLOr checks x) continue throw- where- jsFold op checks value =- foldl1 (InfixExpr () op) (map ($ value) checks)-- throw =- obj ["_U","badPort"] `call` [ string (typeToString jsType), x ]-- checks =- case jsType of- JSNumber -> [typeof "number"]- JSBoolean -> [typeof "boolean"]- JSString -> [typeof "string", instanceof "String"]- JSArray -> [instanceof "Array"]- JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]---incoming :: CanonicalType -> Expression ()-incoming tipe =- case tipe of- Aliased _ t -> incoming t-- App (Type v) [t]- | Var.isSignal v -> obj ["_P","incomingSignal"] <| incoming t-- _ -> ["v"] ==> inc tipe (ref "v")---inc :: CanonicalType -> Expression () -> Expression ()-inc tipe x =- case tipe of- Lambda _ _ -> error "functions should not be allowed through input ports"- Var _ -> error "type variables should not be allowed through input ports"- Aliased _ t ->- inc t x-- Type (Var.Canonical Var.BuiltIn name)- | name == "Int" -> from JSNumber- | name == "Float" -> from JSNumber- | name == "Bool" -> from JSBoolean- | name == "String" -> from JSString- where- from checks = check x checks x-- Type name- | Var.isJson name ->- x-- | Var.isTuple name ->- incomingTuple [] x-- | otherwise ->- error "bad type got to incoming port generation code"-- App f args ->- case f : args of- Type name : [t]- | Var.isMaybe name ->- CondExpr ()- (equal x (NullLit ()))- (_Maybe "Nothing")- (_Maybe "Just" <| inc t x)-- | Var.isList name ->- check x JSArray (_List "fromArray" <| array)-- | Var.isArray name ->- check x JSArray (_Array "fromJSArray" <| array)- where- array = DotRef () x (var "map") <| incoming t-- Type name : ts- | Var.isTuple name -> incomingTuple ts x-- _ -> error "bad ADT got to incoming port generation code"-- Record _ (Just _) ->- error "bad record got to incoming port generation code"-- Record fields Nothing ->- check x (JSObject (map fst fields)) object- where- object = ObjectLit () $ (prop "_", ObjectLit () []) : keys- keys = map convert fields- convert (f,t) = (prop f, inc t (DotRef () x (var f)))---incomingTuple :: [CanonicalType] -> Expression () -> Expression ()-incomingTuple types x =- check x JSArray (ObjectLit () fields)- where- fields = (prop "ctor", ctor) : zipWith convert [0..] types-- ctor = string ("_Tuple" ++ show (length types))-- convert n t =- ( prop ('_':show n)- , inc t (BracketRef () x (IntLit () n))- )---outgoing :: CanonicalType -> Expression ()-outgoing tipe =- case tipe of- Aliased _ t -> outgoing t-- App (Type v) [t]- | Var.isSignal v -> obj ["_P","outgoingSignal"] <| outgoing t-- _ -> ["v"] ==> out tipe (ref "v")---out :: CanonicalType -> Expression () -> Expression ()-out tipe x =- case tipe of- Aliased _ t -> out t x-- Lambda _ _- | numArgs > 1 && numArgs < 10 ->- func (ref ('A':show numArgs) `call` (x:values))- | otherwise -> func (foldl (<|) x values)- where- ts = T.collectLambdas tipe- numArgs = length ts - 1- args = map (\n -> '_' : show n) [0..]- values = zipWith inc (init ts) (map ref args)- func body =- function (take numArgs args)- [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]- , ret (out (last ts) (ref "_r"))- ]-- Var _ -> error "type variables should not be allowed through input ports"-- Type (Var.Canonical Var.BuiltIn name)- | name `elem` ["Int","Float","Bool","String"] -> x-- Type name- | Var.isJson name -> x- | Var.isTuple name -> ArrayLit () []- | otherwise -> error "bad type got to outgoing port generation code"-- App f args ->- case f : args of- Type name : [t]- | Var.isMaybe name ->- CondExpr ()- (equal (DotRef () x (var "ctor")) (string "Nothing"))- (NullLit ())- (out t (DotRef () x (var "_0")))-- | Var.isArray name ->- DotRef () (_Array "toJSArray" <| x) (var "map") <| outgoing t-- | Var.isList name ->- DotRef () (_List "toArray" <| x) (var "map") <| outgoing t-- Type name : ts- | Var.isTuple name ->- let convert n t = out t $ DotRef () x $ var ('_':show n)- in ArrayLit () $ zipWith convert [0..] ts-- _ -> error "bad ADT got to outgoing port generation code"-- Record _ (Just _) ->- error "bad record got to outgoing port generation code"-- Record fields Nothing ->- ObjectLit () keys- where- keys = map convert fields- convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))
src/Parse/Declaration.hs view
@@ -2,7 +2,7 @@ module Parse.Declaration where import Control.Applicative ((<$>))-import Text.Parsec ((<|>), (<?>), choice, digit, optionMaybe, string, try)+import Text.Parsec ( (<|>), (<?>), choice, digit, optionMaybe, string, try ) import qualified AST.Declaration as D import qualified Parse.Expression as Expr@@ -12,13 +12,18 @@ declaration :: IParser D.SourceDecl declaration =- typeDecl <|> infixDecl <|> port <|> definition+ typeDecl <|> infixDecl <|> port <|> definition +-- TYPE ANNOTATIONS and DEFINITIONS+ definition :: IParser D.SourceDecl-definition = D.Definition <$> Expr.def+definition =+ D.Definition <$> (Expr.typeAnnotation <|> Expr.definition) +-- TYPE ALIAS and UNION TYPES+ typeDecl :: IParser D.SourceDecl typeDecl = do try (reserved "type") <?> "type declaration"@@ -39,33 +44,41 @@ return $ D.Datatype name args tcs +-- INFIX+ infixDecl :: IParser D.SourceDecl-infixDecl = do- assoc <-- choice- [ try (reserved "infixl") >> return D.L- , try (reserved "infixr") >> return D.R- , try (reserved "infix") >> return D.N- ]- forcedWS- n <- digit- forcedWS- D.Fixity assoc (read [n]) <$> anyOp+infixDecl =+ do assoc <-+ choice+ [ try (reserved "infixl") >> return D.L+ , try (reserved "infixr") >> return D.R+ , try (reserved "infix") >> return D.N+ ]+ forcedWS+ n <- digit+ forcedWS+ D.Fixity assoc (read [n]) <$> anyOp +-- PORT+ port :: IParser D.SourceDecl port = do try (reserved "port") whitespace name <- lowVar whitespace- let port' op ctor expr =- do try op- whitespace- ctor name <$> expr+ choice [ portAnnotation name, portDefinition name ]+ where+ portAnnotation name =+ do try hasType+ whitespace+ tipe <- Type.expr <?> "a type"+ return (D.Port (D.PortAnnotation name tipe)) - D.Port <$>- choice- [ port' hasType D.PPAnnotation Type.expr- , port' equals D.PPDef Expr.expr- ]+ portDefinition name =+ do try equals+ whitespace+ expr <- Expr.expr+ return (D.Port (D.PortDefinition name expr))+
src/Parse/Expression.hs view
@@ -1,4 +1,4 @@-module Parse.Expression (def,term,typeAnnotation,expr) where+module Parse.Expression (term, typeAnnotation, definition, expr) where import Control.Applicative ((<$>), (<*>)) import qualified Data.List as List@@ -23,33 +23,38 @@ -------- Basic Terms -------- varTerm :: IParser Source.Expr'-varTerm = toVar <$> var <?> "variable"+varTerm =+ toVar <$> var <?> "variable" + toVar :: String -> Source.Expr' toVar v =- case v of- "True" -> E.Literal (L.Boolean True)- "False" -> E.Literal (L.Boolean False)- _ -> E.rawVar v+ case v of+ "True" -> E.Literal (L.Boolean True)+ "False" -> E.Literal (L.Boolean False)+ _ -> E.rawVar v + accessor :: IParser Source.Expr'-accessor = do- (start, lbl, end) <- located (try (string "." >> rLabel))- let loc e = Annotation.at start end e- return (E.Lambda (P.Var "_") (loc $ E.Access (loc $ E.rawVar "_") lbl))+accessor =+ do (start, lbl, end) <- located (try (string "." >> rLabel))+ let loc e = Annotation.at start end e+ return (E.Lambda (P.Var "_") (loc $ E.Access (loc $ E.rawVar "_") lbl)) + negative :: IParser Source.Expr'-negative = do- (start, nTerm, end) <-- located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)- let loc e = Annotation.at start end e- return (E.Binop (Var.Raw "-") (loc $ E.Literal (L.IntNum 0)) nTerm)+negative =+ do (start, nTerm, end) <-+ located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)+ let loc e = Annotation.at start end e+ return (E.Binop (Var.Raw "-") (loc $ E.Literal (L.IntNum 0)) nTerm) -------- Complex Terms -------- listTerm :: IParser Source.Expr'-listTerm = shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)+listTerm =+ shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr) where range = do lo <- expr@@ -64,7 +69,8 @@ parensTerm :: IParser Source.Expr-parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)+parensTerm =+ try (parens opFn) <|> parens (tupleFn <|> parened) where opFn = do (start, op, end) <- located anyOp@@ -79,7 +85,7 @@ loc = Annotation.at start end return $ foldr (\x e -> loc $ E.Lambda x e) (loc . E.tuple $ map (loc . E.rawVar) vars) (map P.Var vars)- + parened = do (start, es, end) <- located (commaSep expr) return $ case es of@@ -87,57 +93,74 @@ _ -> Annotation.at start end (E.tuple es) recordTerm :: IParser Source.Expr-recordTerm = brackets $ choice [ misc, addLocation record ]- where- field = do- label <- rLabel- patterns <- spacePrefix Pattern.term- padded equals- body <- expr- return (label, makeFunction patterns body)- - record = E.Record <$> commaSep field+recordTerm =+ brackets $ choice [ misc, addLocation record ]+ where+ field =+ do label <- rLabel+ patterns <- spacePrefix Pattern.term+ padded equals+ body <- expr+ return (label, makeFunction patterns body) - change = do- lbl <- rLabel- padded (string "<-")- (,) lbl <$> expr+ record =+ E.Record <$> commaSep field - remove r = addLocation (string "-" >> whitespace >> E.Remove r <$> rLabel)+ change =+ do lbl <- rLabel+ padded (string "<-")+ (,) lbl <$> expr - insert r = addLocation $ do- string "|" >> whitespace- E.Insert r <$> rLabel <*> (padded equals >> expr)+ remove r =+ addLocation (string "-" >> whitespace >> E.Remove r <$> rLabel) - modify r =- addLocation (string "|" >> whitespace >> E.Modify r <$> commaSep1 change)+ insert r =+ addLocation $+ do string "|" >> whitespace+ E.Insert r <$> rLabel <*> (padded equals >> expr) - misc = try $ do- record <- addLocation (E.rawVar <$> rLabel)- opt <- padded (optionMaybe (remove record))- case opt of- Just e -> try (insert e) <|> return e- Nothing -> try (insert record) <|> try (modify record)- + modify r =+ addLocation (string "|" >> whitespace >> E.Modify r <$> commaSep1 change) + misc =+ try $ do+ record <- addLocation (E.rawVar <$> rLabel)+ opt <- padded (optionMaybe (remove record))+ case opt of+ Just e -> try (insert e) <|> return e+ Nothing -> try (insert record) <|> try (modify record)++ term :: IParser Source.Expr-term = addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])+term =+ addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ]) <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm) <?> "basic term (4, x, 'c', etc.)" + -------- Applications -------- appExpr :: IParser Source.Expr-appExpr = do- t <- term- ts <- constrainedSpacePrefix term $ \str ->- if null str then notFollowedBy (char '-') else return ()- return $ case ts of- [] -> t- _ -> List.foldl' (\f x -> Annotation.merge f x $ E.App f x) t ts+appExpr =+ do t <- term+ ts <- constrainedSpacePrefix term $ \str ->+ if null str then notFollowedBy (char '-') else return ()+ return $+ case ts of+ [] -> t+ _ -> List.foldl' (\f x -> Annotation.merge f x $ E.App f x) t ts + -------- Normal Expressions -------- +expr :: IParser Source.Expr+expr =+ addLocation (choice [ ifExpr, letExpr, caseExpr ])+ <|> lambdaExpr+ <|> binaryExpr+ <?> "an expression"++ binaryExpr :: IParser Source.Expr binaryExpr = Binop.binops appExpr lastExpr anyOp@@ -152,18 +175,18 @@ whitespace normal <|> multiIf where- normal = do- bool <- expr- padded (reserved "then")- thenBranch <- expr- whitespace <?> "an 'else' branch"- reserved "else" <?> "an 'else' branch"- whitespace- elseBranch <- expr- return $ E.MultiIf- [ (bool, thenBranch)- , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)- ]+ normal =+ do bool <- expr+ padded (reserved "then")+ thenBranch <- expr+ whitespace <?> "an 'else' branch"+ reserved "else" <?> "an 'else' branch"+ whitespace+ elseBranch <- expr+ return $ E.MultiIf+ [ (bool, thenBranch)+ , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)+ ] multiIf = E.MultiIf <$> spaceSep1 iff@@ -184,23 +207,6 @@ return (makeFunction args body) -defSet :: IParser [Source.Def]-defSet =- block $- do d <- def- whitespace- return d---letExpr :: IParser Source.Expr'-letExpr =- do try (reserved "let")- whitespace- defs <- defSet- padded (reserved "in")- E.Let defs <$> expr-- caseExpr :: IParser Source.Expr' caseExpr = do try (reserved "case")@@ -221,20 +227,57 @@ block (do c <- case_ ; whitespace ; return c) -expr :: IParser Source.Expr-expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])- <|> lambdaExpr- <|> binaryExpr - <?> "an expression"+-- LET +letExpr :: IParser Source.Expr'+letExpr =+ do try (reserved "let")+ whitespace+ defs <-+ block $+ do def <- typeAnnotation <|> definition+ whitespace+ return def+ padded (reserved "in")+ E.Let defs <$> expr ++-- TYPE ANNOTATION++typeAnnotation :: IParser Source.Def+typeAnnotation =+ Source.TypeAnnotation <$> try start <*> Type.expr+ where+ start =+ do v <- lowVar <|> parens symOp+ padded hasType+ return v+++-- DEFINITION++definition :: IParser Source.Def+definition =+ withPos $+ do (name:args) <- defStart+ padded equals+ body <- expr+ return . Source.Definition name $ makeFunction args body+++makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr+makeFunction args body@(Annotation.A ann _) =+ foldr (\arg body' -> Annotation.A ann $ E.Lambda arg body') body args++ defStart :: IParser [P.RawPattern] defStart =- choice [ do p1 <- try Pattern.term- infics p1 <|> func p1- , func =<< (P.Var <$> parens symOp)- , (:[]) <$> Pattern.expr- ] <?> "the definition of a variable (x = ...)"+ choice+ [ do p1 <- try Pattern.term+ infics p1 <|> func p1+ , func =<< (P.Var <$> parens symOp)+ ]+ <?> "the definition of a variable (x = ...)" where func pattern = case pattern of@@ -242,30 +285,10 @@ _ -> do try (lookAhead (whitespace >> string "=")) return [pattern] - infics p1 = do- o:p <- try (whitespace >> anyOp)- p2 <- (whitespace >> Pattern.term)- return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]- else [ P.Var (o:p), p1, p2 ]--makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr-makeFunction args body@(Annotation.A ann _) =- foldr (\arg body' -> Annotation.A ann $ E.Lambda arg body') body args--definition :: IParser Source.Def-definition = withPos $ do- (name:args) <- defStart- padded equals- body <- expr- return . Source.Definition name $ makeFunction args body--typeAnnotation :: IParser Source.Def-typeAnnotation = Source.TypeAnnotation <$> try start <*> Type.expr- where- start = do- v <- lowVar <|> parens symOp- padded hasType- return v--def :: IParser Source.Def-def = typeAnnotation <|> definition+ infics p1 =+ do o:p <- try (whitespace >> anyOp)+ p2 <- (whitespace >> Pattern.term)+ return $+ if o == '`'+ then [ P.Var $ takeWhile (/='`') p, p1, p2 ]+ else [ P.Var (o:p), p1, p2 ]
src/Parse/Helpers.hs view
@@ -22,6 +22,7 @@ import qualified AST.Variable as Variable import Elm.Utils ((|>)) + reserveds :: [String] reserveds = [ "if", "then", "else"@@ -29,9 +30,10 @@ , "let", "in" , "type" , "module", "where"- , "import", "as", "hiding", "open"- , "export", "foreign"- , "deriving", "port"+ , "import", "as", "hiding", "exposing"+ , "port", "export", "foreign"+ , "perform"+ , "deriving" ] @@ -82,7 +84,7 @@ innerVarChar :: IParser Char innerVarChar =- alphaNum <|> char '_' <|> char '\'' <?> "" + alphaNum <|> char '_' <|> char '\'' <?> "" makeVar :: IParser Char -> IParser String@@ -251,25 +253,35 @@ accessible :: IParser Source.Expr -> IParser Source.Expr-accessible expr =+accessible exprParser = do start <- getPosition- ce@(Annotation.A _ e) <- expr- let rest f = do- let dot = char '.' >> notFollowedBy (char '.')- access <- optionMaybe (try dot <?> "field access (e.g. List.map)")- case access of- Nothing -> return ce- Just _ -> accessible $ do- v <- var <?> "field access (e.g. List.map)"- end <- getPosition- return (Annotation.at start end (f v))- case e of- E.Var (Variable.Raw (c:cs))- | isUpper c -> rest (\v -> E.rawVar (c:cs ++ '.':v))- | otherwise -> rest (E.Access ce)- _ -> rest (E.Access ce) + annotatedRootExpr@(Annotation.A _ rootExpr) <- exprParser + access <- optionMaybe (try dot <?> "field access (e.g. List.map)")++ case access of+ Nothing ->+ return annotatedRootExpr++ Just _ ->+ accessible $+ do v <- var <?> "field access (e.g. List.map)"+ end <- getPosition+ return . Annotation.at start end $+ case rootExpr of+ E.Var (Variable.Raw name@(c:_))+ | isUpper c ->+ E.rawVar (name ++ '.' : v)+ _ ->+ E.Access annotatedRootExpr v+++dot :: IParser ()+dot =+ char '.' >> notFollowedBy (char '.')++ -- WHITESPACE padded :: IParser a -> IParser a@@ -448,10 +460,10 @@ Left e -> Left e Right (GLS.TranslationUnit decls) -> map extractGLinputs decls- |> join + |> join |> foldr addGLinput emptyDecls |> Right- where + where emptyDecls = L.GLShaderTipe Map.empty Map.empty Map.empty addGLinput (qual,tipe,name) glDecls =@@ -480,11 +492,11 @@ case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of False -> [] True ->- case tipe of + case tipe of GLS.Int -> return (qual, L.Int,name) GLS.Float -> return (qual, L.Float,name) GLS.Vec2 -> return (qual, L.V2,name)- GLS.Vec3 -> return (qual, L.V3,name) + GLS.Vec3 -> return (qual, L.V3,name) GLS.Vec4 -> return (qual, L.V4,name) GLS.Mat4 -> return (qual, L.M4,name) GLS.Sampler2D -> return (qual, L.Texture,name)
src/Parse/Module.hs view
@@ -1,7 +1,6 @@ module Parse.Module (header, headerAndImports, getModuleName) where import Control.Applicative ((<$>), (<*>))-import Data.List (intercalate) import Text.Parsec hiding (newline, spaces) import Parse.Helpers@@ -18,7 +17,7 @@ getModuleName = do optional freshLine (names, _) <- header- return (intercalate "." names)+ return (Module.nameToString names) headerAndImports :: IParser Module.HeaderAndImports@@ -52,19 +51,25 @@ do try (reserved "import") whitespace names <- dotSep1 capVar- (,) names <$> option (Module.As (intercalate "." names)) method+ (,) names <$> method (Module.nameToString names) where- method :: IParser Module.ImportMethod- method = as' <|> importing'+ method :: String -> IParser Module.ImportMethod+ method defaultAlias =+ Module.ImportMethod+ <$> option (Just defaultAlias) (Just <$> as')+ <*> option Var.closedListing exposing - as' :: IParser Module.ImportMethod- as' = do- try (whitespace >> reserved "as")- whitespace- Module.As <$> capVar <?> "alias for module"+ as' :: IParser String+ as' =+ do try (whitespace >> reserved "as")+ whitespace+ capVar <?> "alias for module" - importing' :: IParser Module.ImportMethod- importing' = Module.Open <$> listing value+ exposing :: IParser (Var.Listing Var.Value)+ exposing =+ do try (whitespace >> reserved "exposing")+ whitespace+ listing value listing :: IParser a -> IParser (Var.Listing a)
src/Transform/AddDefaultImports.hs view
@@ -1,47 +1,28 @@-{-# LANGUAGE FlexibleContexts #-} module Transform.AddDefaultImports (add, defaultImports) where -import Prelude hiding (maybe)-import qualified Data.Map as Map- import qualified AST.Module as Module import qualified AST.Variable as Var -type ImportDict =- Map.Map Module.Name ([String], Var.Listing Var.Value)-- -- DESCRIPTION OF DEFAULT IMPORTS (==>) :: a -> b -> (a,b) (==>) = (,) -defaultImports :: ImportDict+defaultImports :: [(Module.Name, Module.ImportMethod)] defaultImports =- Map.fromList- [ ["Basics"] ==> ([], Var.openListing)- , ["List"] ==> ([], Var.Listing [Var.Value "::"] False)- , ["Maybe"] ==> ([], Var.Listing [maybe] False)- , ["Result"] ==> ([], Var.Listing [result] False)- , ["Signal"] ==> ([], Var.Listing [signal] False)+ [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing+ , ["List"] ==> exposing [Var.Value "::"]+ , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]+ , ["Result"] ==> exposing [Var.Union "Result" Var.openListing]+ , ["Signal"] ==> exposing [Var.Alias "Signal"] ] -maybe :: Var.Value-maybe =- Var.Union "Maybe" Var.openListing---result :: Var.Value-result =- Var.Union "Result" Var.openListing---signal :: Var.Value-signal =- Var.Union "Signal" (Var.Listing [] False)+exposing :: [Var.Value] -> Module.ImportMethod+exposing vars =+ Module.ImportMethod Nothing (Var.listing vars) -- ADDING DEFAULT IMPORTS TO A MODULE@@ -51,37 +32,6 @@ Module.Module moduleName path exports ammendedImports decls where ammendedImports =- importDictToList $- foldr addImport (if needsDefaults then defaultImports else Map.empty) imports---importDictToList :: ImportDict -> [(Module.Name, Module.ImportMethod)]-importDictToList dict =- concatMap toImports (Map.toList dict)- where- toImports (name, (qualifiers, listing@(Var.Listing explicits open))) =- map (\qualifier -> (name, Module.As qualifier)) qualifiers- ++- if open || not (null explicits)- then [(name, Module.Open listing)]- else []---addImport :: (Module.Name, Module.ImportMethod) -> ImportDict -> ImportDict-addImport (name, method) importDict =- Map.alter mergeMethods name importDict- where- mergeMethods :: Maybe ([String], Var.Listing Var.Value)- -> Maybe ([String], Var.Listing Var.Value)- mergeMethods entry =- let (qualifiers, listing) =- case entry of- Nothing -> ([], Var.Listing [] False)- Just v -> v- in- case method of- Module.As qualifier ->- Just (qualifier : qualifiers, listing)-- Module.Open newListing ->- Just (qualifiers, newListing)+ if needsDefaults+ then defaultImports ++ imports+ else imports
src/Transform/Canonicalize.hs view
@@ -9,6 +9,7 @@ import qualified Data.Traversable as T import AST.Expression.General (Expr'(..), dummyLet)+import qualified AST.Expression.General as E import qualified AST.Expression.Valid as Valid import qualified AST.Expression.Canonical as Canonical @@ -22,15 +23,19 @@ import qualified AST.Pattern as P import Text.PrettyPrint as P -import Transform.Canonicalize.Environment as Env+import qualified Transform.Canonicalize.Environment as Env import qualified Transform.Canonicalize.Setup as Setup import qualified Transform.Canonicalize.Type as Canonicalize import qualified Transform.Canonicalize.Variable as Canonicalize+import qualified Transform.Canonicalize.Port as Port import qualified Transform.SortDefinitions as Transform import qualified Transform.Declaration as Transform -module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule+module'+ :: Module.Interfaces+ -> Module.ValidModule+ -> Either [Doc] Module.CanonicalModule module' interfaces modul = filterImports <$> modul' where@@ -39,11 +44,14 @@ filterImports m = let used (name,_) = Set.member name usedModules- in m { Module.imports = filter used (Module.imports m) }+ in+ m { Module.imports = filter used (Module.imports m) } -moduleHelp :: Module.Interfaces -> Module.ValidModule- -> Canonicalizer [Doc] Module.CanonicalModule+moduleHelp+ :: Module.Interfaces+ -> Module.ValidModule+ -> Env.Canonicalizer [Doc] Module.CanonicalModule moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) = do env <- Setup.environment interfaces modul canonicalDecls <- mapM (declaration env) decls@@ -70,11 +78,14 @@ , aliases = Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ] , ports =- [ D.portName port | D.Port port <- decls ]+ [ E.portName impl | D.Port (D.CanonicalPort impl) <- decls ] } -resolveExports :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]+resolveExports+ :: [Var.Value]+ -> Var.Listing Var.Value+ -> Env.Canonicalizer [Doc] [Var.Value] resolveExports fullList (Var.Listing partialList open) = if open then return fullList@@ -164,12 +175,15 @@ _ -> [] -declaration :: Environment -> D.ValidDecl -> Canonicalizer [Doc] D.CanonicalDecl+declaration+ :: Env.Environment+ -> D.ValidDecl+ -> Env.Canonicalizer [Doc] D.CanonicalDecl declaration env decl = let canonicalize kind context pattern env v = let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon throw err = P.vcat [ ctx, P.text err ]- in + in Env.onError throw (kind env v) in case decl of@@ -189,25 +203,31 @@ do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded return (D.TypeAlias name tvars expanded') - D.Port port ->- do Env.uses ["Native","Ports"]+ D.Port validPort ->+ do Env.uses ["Native","Port"] Env.uses ["Native","Json"]- D.Port <$>- case port of- D.In name t ->- do t' <- canonicalize Canonicalize.tipe "port" name env t- return (D.In name t')- D.Out name e t ->- do e' <- expression env e- t' <- canonicalize Canonicalize.tipe "port" name env t- return (D.Out name e' t')+ case validPort of+ D.In name tipe ->+ do tipe' <- canonicalize Canonicalize.tipe "port" name env tipe+ port' <- Port.check name Nothing tipe'+ return (D.Port port') ++ D.Out name expr tipe ->+ do expr' <- expression env expr+ tipe' <- canonicalize Canonicalize.tipe "port" name env tipe+ port' <- Port.check name (Just expr') tipe'+ return (D.Port port')+ D.Fixity assoc prec op -> return $ D.Fixity assoc prec op -expression :: Environment -> Valid.Expr -> Canonicalizer [Doc] Canonical.Expr-expression env (A.A ann expr) =+expression+ :: Env.Environment+ -> Valid.Expr+ -> Env.Canonicalizer [Doc] Canonical.Expr+expression env (A.A ann validExpr) = let go = expression env tipe' environ = format . Canonicalize.tipe environ throw err =@@ -218,48 +238,55 @@ format = Env.onError throw in A.A ann <$>- case expr of+ case validExpr of Literal lit -> return (Literal lit) - Range e1 e2 ->- Range <$> go e1 <*> go e2+ Range lowExpr highExpr ->+ Range <$> go lowExpr <*> go highExpr - Access e x ->- Access <$> go e <*> return x+ Access record field ->+ Access <$> go record <*> return field - Remove e x ->- flip Remove x <$> go e+ Remove record field ->+ flip Remove field <$> go record - Insert e x v ->- flip Insert x <$> go e <*> go v+ Insert record field expr ->+ flip Insert field <$> go record <*> go expr - Modify e fs ->- Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs+ Modify record fields ->+ Modify+ <$> go record+ <*> mapM (\(field,expr) -> (,) field <$> go expr) fields - Record fs ->- Record <$> mapM (\(k,v) -> (,) k <$> go v) fs+ Record fields ->+ Record+ <$> mapM (\(field,expr) -> (,) field <$> go expr) fields - Binop (Var.Raw op) e1 e2 ->+ Binop (Var.Raw op) leftExpr rightExpr -> do op' <- format (Canonicalize.variable env op)- Binop op' <$> go e1 <*> go e2+ Binop op' <$> go leftExpr <*> go rightExpr - Lambda p e ->- let env' = update p env in- Lambda <$> format (pattern env' p) <*> expression env' e+ Lambda arg body ->+ let env' = Env.addPattern arg env+ in+ Lambda <$> format (pattern env' arg) <*> expression env' body - App e1 e2 ->- App <$> go e1 <*> go e2+ App func arg ->+ App <$> go func <*> go arg - MultiIf ps ->- MultiIf <$> mapM go' ps+ MultiIf branches ->+ MultiIf <$> mapM go' branches where- go' (b,e) = (,) <$> go b <*> go e+ go' (condition, branch) =+ (,) <$> go condition <*> go branch - Let defs e ->- Let <$> mapM rename' defs <*> expression env' e+ Let defs body ->+ Let <$> mapM rename' defs <*> expression env' body where- env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs+ env' =+ foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs+ rename' (Valid.Definition p body mtipe) = Canonical.Definition <$> format (pattern env' p)@@ -269,30 +296,47 @@ Var (Var.Raw x) -> Var <$> format (Canonicalize.variable env x) - Data name es ->- Data name <$> mapM go es+ Data name exprs ->+ Data name <$> mapM go exprs - ExplicitList es ->- ExplicitList <$> mapM go es+ ExplicitList exprs ->+ ExplicitList <$> mapM go exprs - Case e cases ->- Case <$> go e <*> mapM branch cases+ Case expr cases ->+ Case <$> go expr <*> mapM branch cases where branch (p,b) = (,) <$> format (pattern env p)- <*> expression (update p env) b+ <*> expression (Env.addPattern p env) b - PortIn name st ->- PortIn name <$> tipe' env st+ Port impl ->+ let portType pt =+ case pt of+ Type.Normal t ->+ Type.Normal <$> tipe' env t - PortOut name st signal ->- PortOut name <$> tipe' env st <*> go signal+ Type.Signal root arg ->+ Type.Signal <$> tipe' env root <*> tipe' env arg+ in+ Port <$>+ case impl of+ E.In name tipe ->+ E.In name <$> portType tipe + E.Out name expr tipe ->+ E.Out name <$> go expr <*> portType tipe++ E.Task name expr tipe ->+ E.Task name <$> go expr <*> portType tipe+ GLShader uid src tipe -> return (GLShader uid src tipe) -pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern+pattern+ :: Env.Environment+ -> P.RawPattern+ -> Env.Canonicalizer String P.CanonicalPattern pattern env ptrn = case ptrn of P.Var x -> return $ P.Var x
src/Transform/Canonicalize/Environment.hs view
@@ -16,42 +16,7 @@ import Text.PrettyPrint (Doc) -type Dict a = Map.Map String [a]--dict :: [(String,a)] -> Dict a-dict pairs =- Map.fromList $ map (second (:[])) pairs--insert :: String -> a -> Dict a -> Dict a-insert key value =- Map.insertWith (++) key [value]---type Canonicalizer err a =- Error.ErrorT err (State.State (Set.Set Module.Name)) a--uses :: (Error.Error e) => Module.Name -> Canonicalizer e ()-uses home =- Error.lift (State.modify (Set.insert home))--using :: Var.Canonical -> Canonicalizer String Var.Canonical-using var@(Var.Canonical home _) =- do case home of- Var.BuiltIn -> return ()- Var.Module path -> uses path- Var.Local -> return ()- return var--onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a-onError handler canonicalizer =- do usedModules <- Error.lift State.get- let (result, usedModules') =- State.runState (Error.runErrorT canonicalizer) usedModules- Error.lift (State.put usedModules')- case result of- Left err -> Error.throwError [handler err]- Right x -> return x-+-- ENVIRONMENT data Environment = Env { _home :: Module.Name@@ -61,6 +26,7 @@ , _patterns :: Dict Var.Canonical } + builtIns :: Module.Name -> Environment builtIns home = Env { _home = home@@ -70,22 +36,75 @@ , _patterns = builtIn (tuples ++ ["::","[]"]) } where- builtIn xs = dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs- tuples = map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]+ builtIn xs =+ dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs -update :: P.Pattern var -> Environment -> Environment-update ptrn env =+ tuples =+ map (\n -> "_Tuple" ++ show n) [0 .. 9 :: Int]+++addPattern :: P.Pattern var -> Environment -> Environment+addPattern ptrn env = env { _values = foldr put (_values env) (P.boundVarList ptrn) }- where- put x = Map.insert x [Var.local x]+ where+ put x =+ Map.insert x (Set.singleton (Var.local x)) + merge :: Environment -> Environment -> Environment merge (Env n1 v1 t1 a1 p1) (Env n2 v2 t2 a2 p2)- | n1 /= n2 = error "trying to merge incompatable environments"- | otherwise =- Env { _home = n1- , _values = Map.unionWith (++) v1 v2- , _adts = Map.unionWith (++) t1 t2- , _aliases = Map.unionWith (++) a1 a2- , _patterns = Map.unionWith (++) p1 p2- }+ | n1 /= n2 = error "trying to merge incompatable environments"+ | otherwise =+ Env { _home = n1+ , _values = Map.unionWith Set.union v1 v2+ , _adts = Map.unionWith Set.union t1 t2+ , _aliases = Map.unionWith Set.union a1 a2+ , _patterns = Map.unionWith Set.union p1 p2+ }+++-- RAW NAMES to CANONICAL NAMES++type Dict a =+ Map.Map String (Set.Set a)+++dict :: [(String,a)] -> Dict a+dict pairs =+ Map.fromList (map (second Set.singleton) pairs)+++insert :: (Ord a) => String -> a -> Dict a -> Dict a+insert key value =+ Map.insertWith Set.union key (Set.singleton value)+++-- CANONICALIZATION MANAGER++type Canonicalizer err a =+ Error.ErrorT err (State.State (Set.Set Module.Name)) a+++uses :: (Error.Error e) => Module.Name -> Canonicalizer e ()+uses home =+ Error.lift (State.modify (Set.insert home))+++using :: Var.Canonical -> Canonicalizer String Var.Canonical+using var@(Var.Canonical home _) =+ do case home of+ Var.BuiltIn -> return ()+ Var.Module path -> uses path+ Var.Local -> return ()+ return var+++onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a+onError handler canonicalizer =+ do usedModules <- Error.lift State.get+ let (result, usedModules') =+ State.runState (Error.runErrorT canonicalizer) usedModules+ Error.lift (State.put usedModules')+ case result of+ Left err -> Error.throwError [handler err]+ Right x -> return x
+ src/Transform/Canonicalize/Port.hs view
@@ -0,0 +1,156 @@+module Transform.Canonicalize.Port (check) where++import Control.Applicative ((<$>))+import Control.Monad.Error (throwError)+import Text.PrettyPrint as P++import qualified AST.Declaration as D+import qualified AST.Expression.General as E+import qualified AST.Expression.Canonical as Canonical+import qualified AST.PrettyPrint as PP+import qualified AST.Type as T+import qualified AST.Variable as Var+import qualified Transform.Canonicalize.Environment as Env+++throw :: [Doc] -> Env.Canonicalizer [P.Doc] a+throw err =+ throwError [ P.vcat err ]+++-- CHECK FOR PORT++check+ :: String+ -> Maybe Canonical.Expr+ -> T.CanonicalType+ -> Env.Canonicalizer [P.Doc] D.CanonicalPort+check name maybeExpr rootType =+ do impl <- checkHelp name maybeExpr rootType rootType+ return (D.CanonicalPort impl)+++checkHelp+ :: String+ -> Maybe Canonical.Expr+ -> T.CanonicalType+ -> T.CanonicalType+ -> Env.Canonicalizer [P.Doc] (E.PortImpl Canonical.Expr Var.Canonical)+checkHelp name maybeExpr rootType tipe =+ case (maybeExpr, tipe) of+ (_, T.Aliased _ args t) ->+ checkHelp name maybeExpr rootType (T.dealias args t)++ (Just expr, T.App (T.Type task) [ _x, _a ])+ | Var.isTask task ->+ return (E.Task name expr (T.Normal tipe))+++ (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])+ | Var.isSignal signal && Var.isTask task ->+ return (E.Task name expr (T.Signal tipe arg))+++ (_, T.App (T.Type signal) [arg])+ | Var.isSignal signal ->+ case maybeExpr of+ Nothing ->+ do validForeignType name In arg arg+ return (E.In name (T.Signal rootType arg))++ Just expr ->+ do validForeignType name Out arg arg+ return (E.Out name expr (T.Signal rootType arg))++ _ ->+ case maybeExpr of+ Nothing ->+ do validForeignType name In rootType tipe+ return (E.In name (T.Normal rootType))++ Just expr ->+ do validForeignType name Out rootType tipe+ return (E.Out name expr (T.Normal rootType))+++-- CHECK INBOUND AND OUTBOUND TYPES++data Direction = In | Out+++validForeignType+ :: String+ -> Direction+ -> T.CanonicalType+ -> T.CanonicalType+ -> Env.Canonicalizer [P.Doc] ()+validForeignType name portKind rootType tipe =+ let valid localType =+ validForeignType name portKind rootType localType++ err hint =+ throw (foreignError name portKind rootType tipe hint)+ in+ case tipe of+ T.Aliased _ args t ->+ valid (T.dealias args t)++ T.Type v ->+ case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of+ True -> return ()+ False -> err "It contains an unsupported type"++ T.App t [] ->+ valid t++ T.App (T.Type v) [t]+ | Var.isMaybe v -> valid t+ | Var.isArray v -> valid t+ | Var.isList v -> valid t++ T.App (T.Type v) ts+ | Var.isTuple v -> mapM_ valid ts++ T.App _ _ ->+ err "It contains an unsupported type"++ T.Var _ ->+ err "It contains a free type variable"++ T.Lambda _ _ ->+ err "It contains functions"++ T.Record _ (Just _) ->+ err "It contains extended records with free type variables"++ T.Record fields Nothing ->+ mapM_ (\(k,v) -> (,) k <$> valid v) fields+++foreignError+ :: String+ -> Direction+ -> T.CanonicalType+ -> T.CanonicalType+ -> String+ -> [P.Doc]+foreignError name portKind rootType localType problemMessage =+ [ P.text ("Port Error:")+ , P.nest 4 $+ P.vcat+ [ txt [ "The ", port, " named '", name, "' has an invalid type.\n" ]+ , P.nest 4 (PP.pretty rootType) <> P.text "\n"+ , txt [ problemMessage, ":\n" ]+ , P.nest 4 (PP.pretty localType) <> P.text "\n"+ , txt [ "The kinds of values that can flow through ", port, "s include:" ]+ , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays," ]+ , txt [ " Tuples, JavaScript.Values, and concrete records." ]+ ]+ ]+ where+ port =+ case portKind of+ In -> "inbound port"+ Out -> "outbound port"++ txt = P.text . concat
src/Transform/Canonicalize/Setup.hs view
@@ -23,18 +23,30 @@ import qualified AST.Pattern as P import Text.PrettyPrint as P -import Transform.Canonicalize.Environment as Env+import Transform.Canonicalize.Environment+ ( Canonicalizer, Environment(Env, _home, _values, _adts, _aliases, _patterns) )+import qualified Transform.Canonicalize.Environment as Env import qualified Transform.Canonicalize.Type as Canonicalize import qualified Transform.Interface as Interface -environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment+environment+ :: Module.Interfaces+ -> Module.ValidModule+ -> Canonicalizer [Doc] Environment environment interfaces modul@(Module.Module _ _ _ imports decls) =- do () <- allImportsAvailable- let moduleName = Module.names modul- nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports- let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls- addTypeAliases moduleName aliases env+ do () <- allImportsAvailable+ let moduleName =+ Module.names modul++ nonLocalEnv <-+ foldM (addImports moduleName interfaces) (Env.builtIns moduleName) imports++ let (aliases, env) =+ List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls++ addTypeAliases moduleName aliases env+ where allImportsAvailable :: Canonicalizer [Doc] () allImportsAvailable =@@ -42,63 +54,94 @@ [] -> return () missings -> throwError [ P.text (missingModuleError missings) ] where- modules = map fst imports+ modules =+ map fst imports - found m = Map.member m interfaces || Module.nameIsNative m+ found m =+ Map.member m interfaces || Module.nameIsNative m missingModuleError missings =- concat [ "The following imports were not found:\n "- , List.intercalate ", " (map Module.nameToString missings)- ]+ concat+ [ "The following imports were not found:\n "+ , List.intercalate ", " (map Module.nameToString missings)+ ] -addImports :: Module.Name -> Module.Interfaces -> Environment -> (Module.Name, Module.ImportMethod)- -> Canonicalizer [Doc] Environment+addImports+ :: Module.Name+ -> Module.Interfaces+ -> Environment+ -> (Module.Name, Module.ImportMethod)+ -> Canonicalizer [Doc] Environment addImports moduleName interfaces environ (name, method)- | Module.nameIsNative name = return environ+ | Module.nameIsNative name =+ return environ+ | otherwise =- case method of- Module.As name' ->- return (updateEnviron (name' ++ "."))+ let (Module.ImportMethod maybeAlias listing) = method - Module.Open (Var.Listing vs open)- | open -> return (updateEnviron "")- | otherwise -> foldM (addValue name interface) environ vs- where- interface = Interface.filterExports ((Map.!) interfaces name)+ (Var.Listing exposedVars open) = listing - updateEnviron prefix =- let dict' = dict . map (first (prefix++)) in- merge environ $- Env { _home = moduleName- , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors- , _adts = dict' $ map pair (Map.keys (iAdts interface))- , _aliases = dict' $ map alias (Map.toList (iAliases interface))- , _patterns = dict' $ ctors- }+ qualifier =+ maybe (Module.nameToString name) id maybeAlias - canonical :: String -> Var.Canonical- canonical = Var.Canonical (Var.Module name)+ env =+ updateEnviron (qualifier ++ ".") environ+ in+ if open+ then return (updateEnviron "" env)+ else foldM (addValue name interface) env exposedVars+ where+ interface =+ Interface.filterExports ((Map.!) interfaces name) - pair :: String -> (String, Var.Canonical)- pair key = (key, canonical key)+ updateEnviron prefix env =+ let dict' pairs = Env.dict (map (first (prefix++)) pairs)+ in+ Env.merge env $+ Env+ { _home = moduleName+ , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors+ , _adts = dict' $ map pair (Map.keys (iAdts interface))+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))+ , _patterns = dict' $ ctors+ } - alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))+ canonical :: String -> Var.Canonical+ canonical =+ Var.Canonical (Var.Module name) - ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))+ pair :: String -> (String, Var.Canonical)+ pair key =+ (key, canonical key) -addValue :: Module.Name -> Module.Interface -> Environment -> Var.Value- -> Canonicalizer [Doc] Environment+ alias (x,(tvars,tipe)) =+ (x, (canonical x, tvars, tipe))++ ctors =+ concatMap+ (map (pair . fst) . snd . snd)+ (Map.toList (iAdts interface))+++addValue+ :: Module.Name+ -> Module.Interface+ -> Environment+ -> Var.Value+ -> Canonicalizer [Doc] Environment addValue moduleName interface env value = let name = Module.nameToString moduleName- insert' x = insert x (Var.Canonical (Var.Module moduleName) x)+ insert' x = Env.insert x (Var.Canonical (Var.Module moduleName) x) msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++ "'.\n It is not exported by module " ++ name ++ "." notFound x = throwError [ P.text (msg x) ] in case value of Var.Value x- | Map.notMember x (iTypes interface) -> notFound x+ | Map.notMember x (iTypes interface) ->+ notFound x+ | otherwise -> return $ env { _values = insert' x (_values env) } @@ -106,7 +149,7 @@ case Map.lookup x (iAliases interface) of Just (tvars, t) -> return $ env- { _aliases = insert x v (_aliases env)+ { _aliases = Env.insert x v (_aliases env) , _values = updatedValues } where@@ -126,11 +169,12 @@ case Map.lookup x (iAdts interface) of Nothing -> notFound x Just (_tvars, ctors) ->- do ctors' <- filterNames (map fst ctors)- return $ env { _adts = insert' x (_adts env)- , _values = foldr insert' (_values env) ctors'- , _patterns = foldr insert' (_patterns env) ctors'- }+ do ctors' <- filterNames (map fst ctors)+ return $ env+ { _adts = insert' x (_adts env)+ , _values = foldr insert' (_values env) ctors'+ , _patterns = foldr insert' (_patterns env) ctors'+ } where filterNames names | open = return names@@ -139,21 +183,39 @@ [] -> return names c:_ -> notFound c + type Node = ((String, [String], Type.RawType), String, [String]) + node :: String -> [String] -> Type.RawType -> Node-node name tvars alias = ((name, tvars, alias), name, edges alias)- where- edges tipe =- case tipe of- Type.Lambda t1 t2 -> edges t1 ++ edges t2- Type.Var _ -> []- Type.Type (Var.Raw x) -> [x]- Type.App t ts -> edges t ++ concatMap edges ts- Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs- Type.Aliased _ t -> edges t+node name tvars alias =+ ((name, tvars, alias), name, edges alias)+ where+ edges tipe =+ case tipe of+ Type.Lambda t1 t2 ->+ edges t1 ++ edges t2 + Type.Var _ ->+ [] + Type.Type (Var.Raw x) ->+ [x]++ Type.App t ts ->+ edges t ++ concatMap edges ts++ Type.Record fs ext ->+ maybe [] edges ext ++ concatMap (edges . snd) fs++ Type.Aliased _ args aliasType ->+ case aliasType of+ Type.Holey t ->+ edges t ++ concatMap (edges . snd) args+ Type.Filled t ->+ edges t++ addTypeAliases :: Module.Name -> [Node]@@ -173,14 +235,14 @@ [(name, tvars, alias)] -> do alias' <- Env.onError throw (Canonicalize.tipe env alias) let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')- return $ env { _aliases = insert name value (_aliases env) }+ return $ env { _aliases = Env.insert name value (_aliases env) } where throw err = let msg = "Problem with type alias '" ++ name ++ "':" in P.vcat [ P.text msg, P.text err ] aliases ->- throwError + throwError [ P.vcat [ P.text (eightyCharLines 0 mutuallyRecursiveMessage) , indented (map typeAlias aliases)@@ -191,24 +253,21 @@ ] -typeAlias- :: (String, [String], Type.Type var)- -> D.Declaration' port def var+typeAlias :: (String, [String], Type.Type var) -> D.Declaration' pk def var expr typeAlias (n,ts,t) = D.TypeAlias n ts t -datatype- :: (String, [String], Type.Type var)- -> D.Declaration' port def var+datatype :: (String, [String], Type.Type var) -> D.Declaration' pk def var expr datatype (n,ts,t) = D.Datatype n ts [(n,[t])] indented :: [D.ValidDecl] -> Doc-indented decls = P.vcat (map prty decls) <> P.text "\n"- where- prty decl = P.text "\n " <> pretty decl+indented decls =+ P.vcat (map prty decls) <> P.text "\n"+ where+ prty decl = P.text "\n " <> pretty decl mutuallyRecursiveMessage :: String@@ -232,38 +291,50 @@ -- When canonicalizing, all _values should be Local, but all _adts and _patterns -- should be fully namespaced. With _adts, they may appear in types that can -- escape the module.-addDecl :: Module.Name -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)+addDecl+ :: Module.Name+ -> ([Node], Environment)+ -> D.ValidDecl+ -> ([Node], Environment) addDecl moduleName info@(nodes,env) decl = let namespacedVar = Var.Canonical (Var.Module moduleName)- addLocal x e = insert x (Var.local x) e- addNamespaced x e = insert x (namespacedVar x) e+ addLocal x e = Env.insert x (Var.local x) e+ addNamespaced x e = Env.insert x (namespacedVar x) e in case decl of D.Definition (Valid.Definition pattern _ _) -> (,) nodes $ env- { _values = foldr addLocal (_values env) (P.boundVarList pattern) }+ { _values =+ foldr addLocal (_values env) (P.boundVarList pattern)+ } D.Datatype name _ ctors -> (,) nodes $ env- { _values = addCtors addLocal (_values env)- , _adts = addNamespaced name (_adts env)- , _patterns = addCtors addNamespaced (_patterns env)- }+ { _values =+ addCtors addLocal (_values env)+ , _adts =+ addNamespaced name (_adts env)+ , _patterns =+ addCtors addNamespaced (_patterns env)+ } where addCtors how e = foldr how e (map fst ctors) D.TypeAlias name tvars alias -> (,) (node name tvars alias : nodes) $ env- { _values = case alias of- Type.Record _ _ -> addLocal name (_values env)- _ -> _values env- }+ { _values =+ case alias of+ Type.Record _ _ ->+ addLocal name (_values env)+ _ ->+ _values env+ } D.Port port ->- let portName = case port of- D.Out name _ _ -> name- D.In name _ -> name- in- (,) nodes $ env { _values = addLocal portName (_values env) }+ (,) nodes $ env+ { _values =+ addLocal (D.validPortName port) (_values env)+ } - D.Fixity _ _ _ -> info+ D.Fixity _ _ _ ->+ info
src/Transform/Canonicalize/Type.hs view
@@ -1,10 +1,8 @@ {-# OPTIONS_GHC -Wall #-} module Transform.Canonicalize.Type (tipe) where -import Control.Arrow (second) import Control.Applicative ((<$>),(<*>)) import Control.Monad.Error-import qualified Data.Map as Map import Data.Traversable (traverse) import qualified AST.Type as T@@ -19,7 +17,10 @@ -> T.RawType -> Canonicalizer String T.CanonicalType tipe env typ =- let go = tipe env in+ let go = tipe env+ goSnd (name,t) =+ (,) name <$> go t+ in case typ of T.Var x -> return (T.Var x)@@ -33,15 +34,13 @@ T.Lambda a b -> T.Lambda <$> go a <*> go b - T.Aliased name t ->- T.Aliased name <$> go t- T.Record fields ext ->- let go' (f,t) = (,) f <$> go t- in- T.Record <$> mapM go' fields <*> traverse go ext+ T.Record <$> mapM goSnd fields <*> traverse go ext + T.Aliased _ _ _ ->+ error "a RawType should never have an alias in it" + canonicalizeApp :: Environment -> T.RawType@@ -73,24 +72,13 @@ canonicalizeAlias env (name, tvars, dealiasedTipe) tipes = do when (tipesLen /= tvarsLen) (throwError msg) tipes' <- mapM (tipe env) tipes- let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe- return $ T.Aliased name tipe'+ return $ T.Aliased name (zip tvars tipes') (T.Holey dealiasedTipe) where tipesLen = length tipes tvarsLen = length tvars msg :: String- msg = "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++- " type argument" ++ (if tvarsLen == 1 then "" else "s") ++- " but was given " ++ show tipesLen-- replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType- replace typeTable t =- let go = replace typeTable in- case t of- T.Lambda a b -> T.Lambda (go a) (go b)- T.Var x -> Map.findWithDefault t x typeTable- T.Record fields ext -> T.Record (map (second go) fields) (fmap go ext)- T.Aliased original t' -> T.Aliased original (go t')- T.Type _ -> t- T.App f args -> T.App (go f) (map go args)+ msg =+ "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen +++ " type argument" ++ (if tvarsLen == 1 then "" else "s") +++ " but was given " ++ show tipesLen
src/Transform/Canonicalize/Variable.hs view
@@ -2,76 +2,90 @@ module Transform.Canonicalize.Variable where import Control.Monad.Error+import qualified Data.Either as Either+import Data.Function (on) import qualified Data.List as List import qualified Data.Map as Map-import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import qualified Text.EditDistance as Dist -import AST.Helpers as Help+import qualified AST.Helpers as Help import qualified AST.Module as Module import qualified AST.Type as Type import qualified AST.Variable as Var import Transform.Canonicalize.Environment as Env+import Elm.Utils ((|>)) + variable :: Environment -> String -> Canonicalizer String Var.Canonical variable env var =- case modul of- Just name+ case splitName var of+ Right (name, varName) | Module.nameIsNative name -> Env.using (Var.Canonical (Var.Module name) varName) _ ->- case Map.lookup var (_values env) of+ case Set.toList `fmap` Map.lookup var (_values env) of Just [v] -> Env.using v Just vs -> preferLocals env "variable" vs var Nothing -> notFound "variable" (Map.keys (_values env)) var- where- (modul, varName) =- case Help.splitDots var of- [x] -> (Nothing, x)- xs -> (Just (init xs), last xs) -tvar :: Environment -> String- -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType))++tvar+ :: Environment+ -> String+ -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType)) tvar env var = case adts ++ aliases of [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var [v] -> found extract v vs -> preferLocals' env extract "type" vs var where- adts = map Left . fromMaybe [] $ Map.lookup var (_adts env)- aliases = map Right . fromMaybe [] $ Map.lookup var (_aliases env)+ adts =+ map Left (maybe [] Set.toList (Map.lookup var (_adts env))) + aliases =+ map Right (maybe [] Set.toList (Map.lookup var (_aliases env)))+ extract value = case value of Left v -> v Right (v,_,_) -> v + pvar :: Environment -> String -> Canonicalizer String Var.Canonical pvar env var =- case Map.lookup var (_patterns env) of+ case Set.toList `fmap` Map.lookup var (_patterns env) of Just [v] -> Env.using v Just vs -> preferLocals env "pattern" vs var Nothing -> notFound "pattern" (Map.keys (_patterns env)) var ++-- FOUND+ found :: (a -> Var.Canonical) -> a -> Canonicalizer String a-found extract v = do- _ <- Env.using (extract v)- return v+found extract v =+ do _ <- Env.using (extract v)+ return v -notFound :: String -> [String] -> String -> Canonicalizer String a-notFound kind possibilities var =- throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ msg- where- matches = filter (List.isInfixOf var) possibilities- msg = if null matches then "" else- "\nClose matches include: " ++ List.intercalate ", " matches -preferLocals :: Environment -> String -> [Var.Canonical] -> String- -> Canonicalizer String Var.Canonical-preferLocals env = preferLocals' env id+preferLocals+ :: Environment+ -> String+ -> [Var.Canonical]+ -> String+ -> Canonicalizer String Var.Canonical+preferLocals env =+ preferLocals' env id -preferLocals' :: Environment -> (a -> Var.Canonical) -> String -> [a] -> String- -> Canonicalizer String a++preferLocals'+ :: Environment+ -> (a -> Var.Canonical)+ -> String+ -> [a]+ -> String+ -> Canonicalizer String a preferLocals' env extract kind possibilities var = case filter (isLocal . extract) possibilities of [] -> ambiguous possibilities@@ -92,4 +106,137 @@ vars = map (Var.toString . extract) possibleVars msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++ " Disambiguate between: " ++ List.intercalate ", " vars+++-- NOT FOUND HELPERS++splitName :: String -> Either String ([String], String)+splitName var =+ case Help.splitDots var of+ [x] -> Left x+ xs -> Right (init xs, last xs)+++getName :: Either String ([String], String) -> String+getName name =+ case name of+ Left x -> x+ Right (_, x) -> x+++nameToString :: ([String], String) -> String+nameToString (modul, name) =+ Module.nameToString (modul ++ [name])+++isOp :: Either String ([String], String) -> Bool+isOp name =+ Help.isOp (getName name)+++distance :: String -> String -> Int+distance x y =+ Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y+++nearbyNames :: (a -> String) -> a -> [a] -> [a]+nearbyNames format name names =+ let editDistance =+ if length (format name) < 3 then 1 else 2+ in+ names+ |> map (\x -> (distance (format name) (format x), x))+ |> List.sortBy (compare `on` fst)+ |> filter ( (<= editDistance) . abs . fst )+ |> map snd+++-- NOT FOUND++notFound :: String -> [String] -> String -> Canonicalizer String a+notFound kind possibilities var =+ let possibleNames =+ map splitName possibilities++ name =+ splitName var++ closeNames =+ possibleNames+ |> filter (\n -> isOp name == isOp n)+ |> nearbyNames getName name++ (exposed, qualified) =+ Either.partitionEithers closeNames++ message =+ case name of+ Left _ ->+ closeExposedMessage exposed ++ closeQualifiedMessage qualified++ Right (modul, _) ->+ qualifiedMessage modul (Either.rights possibleNames) qualified++ in+ throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ message++++closeExposedMessage :: [String] -> String+closeExposedMessage exposed =+ if null exposed+ then ""+ else+ "\n\nClose matches include:" ++ concatMap ("\n " ++) exposed+++closeQualifiedMessage :: [([String], String)] -> String+closeQualifiedMessage qualified =+ if null qualified+ then ""+ else+ "\n\nMaybe you forgot to say which module it came from?\n"+ ++ "Close qualified names include:"+ ++ concatMap (("\n " ++) . nameToString) qualified+ ++ usingImportsMessage+++qualifiedMessage :: [String] -> [([String], String)] -> [([String], String)] -> String+qualifiedMessage modul allQualified qualified =+ let availableModules =+ Set.fromList (map fst allQualified)+ in+ case Set.member modul availableModules of+ True ->+ let inSameModule =+ filter ((==) modul . fst) qualified+ in+ if null inSameModule+ then ""+ else+ "\n\nClose matches include:"+ ++ concatMap (("\n " ++) . nameToString) inSameModule++ False ->+ let closeModules =+ Set.toList availableModules+ |> map Module.nameToString+ |> nearbyNames id (Module.nameToString modul)+ in+ case closeModules of+ [] ->+ "\n\nLooks like the prefix '" ++ Module.nameToString modul+ ++ "' is not in scope. Is it spelled correctly?"+ ++ "\nIs it imported correctly?"+ ++ usingImportsMessage++ _ ->+ "\n\nClose matches to '" ++ Module.nameToString modul ++ "' include:"+ ++ concatMap ("\n " ++) closeModules+++usingImportsMessage :: String+usingImportsMessage =+ "\n\nYou can read about how imports work at the following address:"+ ++ "\n<http://elm-lang.org/learn/Syntax.elm#modules>"
src/Transform/Check.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -Wall #-} module Transform.Check (mistakes) where -import qualified Control.Arrow as Arrow import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Data.Set as Set@@ -23,12 +22,14 @@ mistakes decls = concat [ infiniteTypeAliases decls- , illFormedTypes decls+ , illFormedTypeDecls decls , map P.text (duplicateTypeDeclarations decls) , map P.text (duplicateValues decls) ] +-- DUPLICATES+ dups :: Ord a => [a] -> [a] dups names = List.sort names@@ -40,7 +41,7 @@ duplicateValues :: [D.ValidDecl] -> [String] duplicateValues decls = map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++- case mapM exprDups (portExprs ++ defExprs) of+ case mapM exprDups defExprs of Left name -> [msg name] Right _ -> [] @@ -51,15 +52,12 @@ (defPatterns, defExprs) = unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ] - (portNames, portExprs) =- Arrow.second concat $ unzip $ - flip map [ port | D.Port port <- decls ] $ \port ->- case port of- D.Out name expr _ -> (name, [expr])- D.In name _ -> (name, [])+ portNames =+ [ D.validPortName port | D.Port port <- decls ] exprDups :: Valid.Expr -> Either String Valid.Expr- exprDups expr = Expr.crawlLet defsDups expr+ exprDups expr =+ Expr.crawlLet defsDups expr defsDups :: [Valid.Def] -> Either String [Valid.Def] defsDups defs =@@ -70,7 +68,7 @@ duplicateTypeDeclarations :: [D.ValidDecl] -> [String]-duplicateTypeDeclarations decls = +duplicateTypeDeclarations decls = map dupTypeError (dups (typeNames ++ aliasNames)) ++ map dupCtorError (dups (ctorNames ++ aliasNames)) where@@ -96,82 +94,123 @@ ++ " something should be renamed or moved to a different module." -illFormedTypes :: [D.ValidDecl] -> [Doc]-illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))- where- aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]- adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]+-- FREE TYPE VARIABLES IN TYPE DECLARATIONS - freeVars tipe =- case tipe of- T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)- T.Var x -> Set.singleton x- T.Type _ -> Set.empty- T.App t ts -> Set.unions (map freeVars (t:ts))- T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)- where ext' = maybe Set.empty freeVars ext- T.Aliased _ t -> freeVars t+illFormedTypeDecls :: [D.ValidDecl] -> [Doc]+illFormedTypeDecls decls =+ map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))+ where+ aliases =+ [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ] - undeclared tvars tipes = Set.difference used declared- where- used = Set.unions (map freeVars tipes)- declared = Set.fromList tvars+ adts =+ [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ] - isIllFormed (decl, tvars, tipes) =- let unbound = undeclared tvars tipes in - if Set.null unbound then Nothing- else Just (decl, Set.toList unbound)+ freeVars tipe =+ case tipe of+ T.Lambda t1 t2 ->+ Set.union (freeVars t1) (freeVars t2) - report (decl, tvars) =- P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"- , P.text "\n"- , nest 4 (pretty decl) ]- where- listing =- case tvars of- [tvar] -> " " ++ quote tvar ++ " is"- _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"+ T.Var x ->+ Set.singleton x - addCommas xs- | length xs < 3 = concat xs- | otherwise = List.intercalate "," xs+ T.Type _ ->+ Set.empty - addAnd xs- | length xs < 2 = xs- | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs+ T.App t ts ->+ Set.unions (map freeVars (t:ts)) - quote tvar = "'" ++ tvar ++ "'"+ T.Record fields ext ->+ let ext' = maybe Set.empty freeVars ext+ in+ Set.unions (ext' : map (freeVars . snd) fields) + T.Aliased _ args t ->+ freeVars (T.dealias args t) + undeclared tvars tipes =+ Set.difference used declared+ where+ used = Set.unions (map freeVars tipes)+ declared = Set.fromList tvars++ isIllFormed (decl, tvars, tipes) =+ let unbound = undeclared tvars tipes in+ if Set.null unbound+ then Nothing+ else Just (decl, Set.toList unbound)++ report (decl, tvars) =+ P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"+ , P.text "\n"+ , nest 4 (pretty decl) ]+ where+ listing =+ case tvars of+ [tvar] -> " " ++ quote tvar ++ " is"+ _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"++ addCommas xs+ | length xs < 3 = concat xs+ | otherwise = List.intercalate "," xs++ addAnd xs+ | length xs < 2 = xs+ | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs++ quote tvar = "'" ++ tvar ++ "'"+++-- INFINITE TYPE ALIASES+ infiniteTypeAliases :: [D.ValidDecl] -> [Doc] infiniteTypeAliases decls =- [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls- , infiniteType name tipe ]- where- infiniteType :: String -> T.Type Var.Raw -> Bool- infiniteType name tipe =- let infinite = infiniteType name in- case tipe of- T.Lambda a b -> infinite a || infinite b- T.Var _ -> False- T.Type (Var.Raw name') -> name == name'- T.App t ts -> any infinite (t:ts)- T.Record fields _ -> any (infinite . snd) fields- T.Aliased _ t -> infinite t+ [ report name tvars tipe+ | D.TypeAlias name tvars tipe <- decls+ , infiniteType name tipe+ ]+ where+ infiniteType :: String -> T.Type Var.Raw -> Bool+ infiniteType name tipe =+ let infinite = infiniteType name in+ case tipe of+ T.Lambda a b ->+ infinite a || infinite b - indented :: D.ValidDecl -> Doc- indented decl = P.text "\n " <> pretty decl <> P.text "\n"+ T.Var _ ->+ False - report name args tipe =- P.vcat- [ P.text $ eightyCharLines 0 msg1- , indented $ D.TypeAlias name args tipe- , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue- , indented $ D.Datatype name args [(name,[tipe])]- , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n"- ]- where- msg1 =- "Type alias '" ++ name ++ "' is an infinite type. " ++- "Notice that it appears in its own definition, so when \- \you expand it, it just keeps getting bigger:"+ T.Type (Var.Raw name') ->+ name == name'++ T.App t ts ->+ any infinite (t:ts)++ T.Record fields _ ->+ any (infinite . snd) fields++ T.Aliased _ args aliasType ->+ case aliasType of+ T.Holey t ->+ infinite t || any (infinite . snd) args++ T.Filled t ->+ infinite t++ indented :: D.ValidDecl -> Doc+ indented decl =+ P.text "\n " <> pretty decl <> P.text "\n"++ report name args tipe =+ P.vcat+ [ P.text $ eightyCharLines 0 msg1+ , indented $ D.TypeAlias name args tipe+ , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue+ , indented $ D.Datatype name args [(name,[tipe])]+ , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n"+ ]+ where+ msg1 =+ "Type alias '" ++ name ++ "' is an infinite type. " +++ "Notice that it appears in its own definition, so when \+ \you expand it, it just keeps getting bigger:"
src/Transform/Declaration.hs view
@@ -19,111 +19,140 @@ combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]-combineAnnotations = go- where- msg x = "Syntax Error: The type annotation for '" ++ x ++- "' must be directly above its definition."+combineAnnotations =+ go+ where+ errorMessage kind name =+ "Syntax Error: The type annotation for " ++ kind ++ " '" +++ name ++ "' must be directly above its definition." - exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations+ exprCombineAnnotations =+ Expr.crawlLet Def.combineAnnotations - go decls =- case decls of- -- simple cases, pass them through with no changes- [] -> return []+ go decls =+ case decls of+ -- simple cases, pass them through with no changes+ [] ->+ return [] - D.Datatype name tvars ctors : rest ->- (:) (D.Datatype name tvars ctors) <$> go rest+ D.Datatype name tvars ctors : rest ->+ (:) (D.Datatype name tvars ctors) <$> go rest - D.TypeAlias name tvars alias : rest ->- (:) (D.TypeAlias name tvars alias) <$> go rest+ D.TypeAlias name tvars alias : rest ->+ (:) (D.TypeAlias name tvars alias) <$> go rest - D.Fixity assoc prec op : rest ->- (:) (D.Fixity assoc prec op) <$> go rest+ D.Fixity assoc prec op : rest ->+ (:) (D.Fixity assoc prec op) <$> go rest - -- combine definitions- D.Definition def : defRest ->- case def of- Source.Definition pat expr ->- do expr' <- exprCombineAnnotations expr- let def' = Valid.Definition pat expr' Nothing- (:) (D.Definition def') <$> go defRest+ -- combine definitions+ D.Definition def : defRest ->+ case def of+ Source.Definition pat expr ->+ do expr' <- exprCombineAnnotations expr+ let def' = Valid.Definition pat expr' Nothing+ (:) (D.Definition def') <$> go defRest - Source.TypeAnnotation name tipe ->- case defRest of- D.Definition (Source.Definition pat@(P.Var name') expr) : rest- | name == name' ->- do expr' <- exprCombineAnnotations expr- let def' = Valid.Definition pat expr' (Just tipe)- (:) (D.Definition def') <$> go rest+ Source.TypeAnnotation name tipe ->+ case defRest of+ D.Definition (Source.Definition pat@(P.Var name') expr) : rest+ | name == name' ->+ do expr' <- exprCombineAnnotations expr+ let def' = Valid.Definition pat expr' (Just tipe)+ (:) (D.Definition def') <$> go rest - _ -> Left (msg name)+ _ -> Left (errorMessage "value" name) - -- combine ports- D.Port port : portRest ->- case port of- D.PPDef name _ -> Left (msg name)- D.PPAnnotation name tipe ->- case portRest of- D.Port (D.PPDef name' expr) : rest | name == name' ->- do expr' <- exprCombineAnnotations expr- (:) (D.Port (D.Out name expr' tipe)) <$> go rest+ D.Port port : rest ->+ case port of+ D.PortAnnotation name tipe ->+ case rest of+ D.Port (D.PortDefinition name' expr) : restRest+ | name == name' ->+ do expr' <- exprCombineAnnotations expr+ let port' = D.Out name expr' tipe+ (:) (D.Port port') <$> go restRest - _ -> (:) (D.Port (D.In name tipe)) <$> go portRest+ _ ->+ (:) (D.Port (D.In name tipe)) <$> go rest + D.PortDefinition name _ ->+ Left (errorMessage "port" name) + toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]-toExpr moduleName = concatMap (toDefs moduleName)+toExpr moduleName =+ concatMap (toDefs moduleName) + toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def] toDefs moduleName decl = let typeVar = Var.Canonical (Var.Module moduleName) in case decl of- D.Definition def -> [def]+ D.Definition def ->+ [def] - D.Datatype name tvars constructors -> concatMap toDefs' constructors+ D.Datatype name tvars constructors ->+ concatMap toDefs' constructors where toDefs' (ctor, tipes) = let vars = take (length tipes) arguments tbody = T.App (T.Type (typeVar name)) (map T.Var tvars) body = A.none . E.Data ctor $ map (A.none . E.localVar) vars- in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]+ in+ [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ] - D.TypeAlias name _ tipe@(T.Record fields ext) ->+ D.TypeAlias name tvars tipe@(T.Record fields ext) -> [ definition name (buildFunction record vars) (foldr T.Lambda result args) ] where- result = T.Aliased (typeVar name) tipe+ result =+ T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe) - args = map snd fields ++ maybe [] (:[]) ext+ args =+ map snd fields ++ maybe [] (:[]) ext var = A.none . E.localVar vars = take (length args) arguments efields = zip (map fst fields) (map var vars)- record = case ext of- Nothing -> A.none $ E.Record efields- Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields+ record =+ case ext of+ Nothing -> A.none $ E.Record efields+ Just _ ->+ foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields -- Type aliases must be added to an extended equality dictionary, -- but they do not require any basic constraints.- D.TypeAlias _ _ _ -> []+ D.TypeAlias _ _ _ ->+ [] - D.Port port ->- case port of- D.Out name expr@(A.A s _) tipe ->- [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]- D.In name tipe ->- [ definition name (A.none $ E.PortIn name tipe) tipe ]+ D.Port (D.CanonicalPort impl) ->+ let body = A.none (E.Port impl)+ in+ case impl of+ E.In name tipe ->+ [ definition name body (T.portType tipe) ] + E.Out name _expr tipe ->+ [ definition name body (T.portType tipe) ]++ E.Task name _expr tipe ->+ [ definition name body (T.portType tipe) ]+ -- no constraints are needed for fixity declarations- D.Fixity _ _ _ -> []+ D.Fixity _ _ _ ->+ [] arguments :: [String]-arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]+arguments =+ map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..] + buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr buildFunction body@(A.A s _) vars =- foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)+ foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars) + definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def-definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe)+definition name expr tipe =+ Canonical.Definition (P.Var name) expr (Just tipe)
src/Transform/Definition.hs view
@@ -8,28 +8,33 @@ import qualified Transform.Expression as Expr combineAnnotations :: [Source.Def] -> Either String [Valid.Def]-combineAnnotations = go- where- msg x = "Syntax Error: The type annotation for '" ++ x ++- "' must be directly above its definition."+combineAnnotations =+ go+ where+ errorMessage x =+ "Syntax Error: The type annotation for '" ++ x +++ "' must be directly above its definition." - exprCombineAnnotations = Expr.crawlLet combineAnnotations+ exprCombineAnnotations =+ Expr.crawlLet combineAnnotations - go defs =- case defs of- Source.TypeAnnotation name tipe : rest ->- case rest of- Source.Definition pat@(P.Var name') expr : rest'- | name == name' ->- do expr' <- exprCombineAnnotations expr- let def = Valid.Definition pat expr' (Just tipe)- (:) def <$> go rest'+ go defs =+ case defs of+ Source.TypeAnnotation name tipe : rest ->+ case rest of+ Source.Definition pat@(P.Var name') expr : rest'+ | name == name' ->+ do expr' <- exprCombineAnnotations expr+ let def = Valid.Definition pat expr' (Just tipe)+ (:) def <$> go rest' - _ -> Left (msg name)+ _ ->+ Left (errorMessage name) - Source.Definition pat expr : rest ->- do expr' <- exprCombineAnnotations expr- let def = Valid.Definition pat expr' Nothing- (:) def <$> go rest+ Source.Definition pat expr : rest ->+ do expr' <- exprCombineAnnotations expr+ let def = Valid.Definition pat expr' Nothing+ (:) def <$> go rest - [] -> return []+ [] ->+ return []
src/Transform/Expression.hs view
@@ -1,53 +1,29 @@ {-# OPTIONS_GHC -Wall #-}-module Transform.Expression (crawlLet, checkPorts) where+module Transform.Expression (crawlLet) where import Control.Applicative ((<$>),(<*>)) import AST.Annotation ( Annotated(A) ) import AST.Expression.General-import qualified AST.Expression.Canonical as Canonical-import AST.Type (Type, CanonicalType) + crawlLet :: ([def] -> Either a [def']) -> Expr ann def var -> Either a (Expr ann def' var)-crawlLet =- crawl (\_ _ -> return ()) (\_ _ -> return ())---checkPorts- :: (String -> CanonicalType -> Either a ())- -> (String -> CanonicalType -> Either a ())- -> Canonical.Expr- -> Either a Canonical.Expr-checkPorts inCheck outCheck expr =- crawl inCheck outCheck (mapM checkDef) expr- where- checkDef def@(Canonical.Definition _ body _) =- do _ <- checkPorts inCheck outCheck body- return def---crawl- :: (String -> Type var -> Either a ())- -> (String -> Type var -> Either a ())- -> ([def] -> Either a [def'])- -> Expr ann def var- -> Either a (Expr ann def' var)-crawl portInCheck portOutCheck defsTransform =- go+crawlLet defsTransform annotatedExpression =+ go annotatedExpression where- go (A srcSpan expr) =+ go (A srcSpan expression) = A srcSpan <$>- case expr of+ case expression of Var x -> return (Var x) - Lambda p e ->- Lambda p <$> go e+ Lambda pattern body ->+ Lambda pattern <$> go body - Binop op e1 e2 ->- Binop op <$> go e1 <*> go e2+ Binop op leftExpr rightExpr ->+ Binop op <$> go leftExpr <*> go rightExpr Case e cases -> Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases@@ -58,32 +34,34 @@ Literal lit -> return (Literal lit) - Range e1 e2 ->- Range <$> go e1 <*> go e2+ Range lowExpr highExpr ->+ Range <$> go lowExpr <*> go highExpr - ExplicitList es ->- ExplicitList <$> mapM go es+ ExplicitList expressions ->+ ExplicitList <$> mapM go expressions - App e1 e2 ->- App <$> go e1 <*> go e2+ App funcExpr argExpr ->+ App <$> go funcExpr <*> go argExpr MultiIf branches -> MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches - Access e lbl ->- Access <$> go e <*> return lbl+ Access record field ->+ Access <$> go record <*> return field - Remove e lbl ->- Remove <$> go e <*> return lbl+ Remove record field ->+ Remove <$> go record <*> return field - Insert e lbl v ->- Insert <$> go e <*> return lbl <*> go v+ Insert record field expr ->+ Insert <$> go record <*> return field <*> go expr - Modify e fields ->- Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields+ Modify record fields ->+ Modify+ <$> go record+ <*> mapM (\(field,expr) -> (,) field <$> go expr) fields Record fields ->- Record <$> mapM (\(k,v) -> (,) k <$> go v) fields+ Record <$> mapM (\(field,expr) -> (,) field <$> go expr) fields Let defs body -> Let <$> defsTransform defs <*> go body@@ -91,10 +69,16 @@ GLShader uid src gltipe -> return $ GLShader uid src gltipe - PortIn name st ->- do portInCheck name st- return $ PortIn name st+ Port impl ->+ Port <$>+ case impl of+ In name tipe ->+ return (In name tipe) - PortOut name st signal ->- do portOutCheck name st- PortOut name st <$> go signal+ Out name expr tipe ->+ do expr' <- go expr+ return (Out name expr' tipe)++ Task name expr tipe ->+ do expr' <- go expr+ return (Task name expr' tipe)
src/Transform/SortDefinitions.hs view
@@ -9,11 +9,12 @@ import qualified Data.Set as Set import AST.Annotation-import AST.Expression.General (Expr'(..))+import AST.Expression.General (Expr'(..), PortImpl(..)) import qualified AST.Expression.Canonical as Canonical import qualified AST.Pattern as P import qualified AST.Variable as V + ctors :: P.CanonicalPattern -> [String] ctors pattern = case pattern of@@ -30,129 +31,159 @@ where rest = concatMap ctors ps + free :: String -> State (Set.Set String) ()-free x = modify (Set.insert x)+free x =+ modify (Set.insert x) + freeIfLocal :: V.Canonical -> State (Set.Set String) () freeIfLocal (V.Canonical home name) =- do case home of- V.Local -> free name- V.BuiltIn -> return ()- V.Module _ -> return ()+ case home of+ V.Local -> free name+ V.BuiltIn -> return ()+ V.Module _ -> return () + bound :: Set.Set String -> State (Set.Set String) ()-bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)+bound boundVars =+ modify (\freeVars -> Set.difference freeVars boundVars) + sortDefs :: Canonical.Expr -> Canonical.Expr-sortDefs expr = evalState (reorder expr) Set.empty+sortDefs expression =+ evalState (reorder expression) Set.empty + reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr-reorder (A ann expr) =+reorder (A ann expression) = A ann <$>- case expr of+ case expression of -- Be careful adding and restricting freeVars- Var var -> freeIfLocal var >> return expr+ Var var ->+ do freeIfLocal var+ return expression - Lambda p e ->- uncurry Lambda <$> bindingReorder (p,e)+ Lambda pattern body ->+ uncurry Lambda <$> bindingReorder (pattern,body) - Binop op e1 e2 ->- do freeIfLocal op- Binop op <$> reorder e1 <*> reorder e2+ Binop op leftExpr rightExpr ->+ do freeIfLocal op+ Binop op <$> reorder leftExpr <*> reorder rightExpr - Case e cases ->- Case <$> reorder e <*> mapM bindingReorder cases+ Case expr cases ->+ Case <$> reorder expr <*> mapM bindingReorder cases - Data name es ->- do free name- Data name <$> mapM reorder es+ Data name exprs ->+ do free name+ Data name <$> mapM reorder exprs -- Just pipe the reorder though- Literal _ -> return expr+ Literal _ ->+ return expression - Range e1 e2 ->- Range <$> reorder e1 <*> reorder e2+ Range lowExpr highExpr ->+ Range <$> reorder lowExpr <*> reorder highExpr ExplicitList es -> ExplicitList <$> mapM reorder es - App e1 e2 ->- App <$> reorder e1 <*> reorder e2+ App func arg ->+ App <$> reorder func <*> reorder arg MultiIf branches ->- MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches+ MultiIf <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches - Access e lbl ->- Access <$> reorder e <*> return lbl+ Access record field ->+ Access <$> reorder record <*> return field - Remove e lbl ->- Remove <$> reorder e <*> return lbl+ Remove record field ->+ Remove <$> reorder record <*> return field - Insert e lbl v ->- Insert <$> reorder e <*> return lbl <*> reorder v+ Insert record field expr ->+ Insert <$> reorder record <*> return field <*> reorder expr - Modify e fields ->- Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields+ Modify record fields ->+ Modify+ <$> reorder record+ <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields Record fields ->- Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields+ Record+ <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields - GLShader _ _ _ -> return expr+ GLShader _ _ _ ->+ return expression - PortOut name st signal -> PortOut name st <$> reorder signal+ Port impl ->+ Port <$>+ case impl of+ In _ _ ->+ return impl - PortIn name st -> return $ PortIn name st+ Out name expr tipe ->+ (\e -> Out name e tipe) <$> reorder expr + Task name expr tipe ->+ (\e -> Task name e tipe) <$> reorder expr+ -- Actually do some reordering Let defs body ->- do body' <- reorder body+ do body' <- reorder body - -- Sort defs into strongly connected components.This- -- allows the programmer to write definitions in whatever- -- order they please, we can still define things in order- -- and generalize polymorphic functions when appropriate.- sccs <- Graph.stronglyConnComp <$> buildDefDict defs- let defss = map Graph.flattenSCC sccs- - -- remove let-bound variables from the context- forM_ defs $ \(Canonical.Definition pattern _ _) -> do- bound (P.boundVars pattern)- mapM free (ctors pattern)+ -- Sort defs into strongly connected components.This+ -- allows the programmer to write definitions in whatever+ -- order they please, we can still define things in order+ -- and generalize polymorphic functions when appropriate.+ sccs <- Graph.stronglyConnComp <$> buildDefDict defs+ let defss = map Graph.flattenSCC sccs - let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss+ -- remove let-bound variables from the context+ forM_ defs $ \(Canonical.Definition pattern _ _) -> do+ bound (P.boundVars pattern)+ mapM free (ctors pattern) - return let'+ let A _ let' =+ foldr (\ds bod -> A ann (Let ds bod)) body' defss -bindingReorder :: (P.CanonicalPattern, Canonical.Expr)- -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)+ return let'+++bindingReorder+ :: (P.CanonicalPattern, Canonical.Expr)+ -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr) bindingReorder (pattern,expr) =- do expr' <- reorder expr- bound (P.boundVars pattern)- mapM_ free (ctors pattern)- return (pattern, expr')+ do expr' <- reorder expr+ bound (P.boundVars pattern)+ mapM_ free (ctors pattern)+ return (pattern, expr') -reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String])+reorderAndGetDependencies+ :: Canonical.Def+ -> State (Set.Set String) (Canonical.Def, [String]) reorderAndGetDependencies (Canonical.Definition pattern expr mType) =- do globalFrees <- get- -- work in a fresh environment- put Set.empty- expr' <- reorder expr- localFrees <- get- -- merge with global frees- modify (Set.union globalFrees)- return (Canonical.Definition pattern expr' mType, Set.toList localFrees)+ do globalFrees <- get+ -- work in a fresh environment+ put Set.empty+ expr' <- reorder expr+ localFrees <- get+ -- merge with global frees+ modify (Set.union globalFrees)+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees) -- This also reorders the all of the sub-expressions in the Def list.-buildDefDict :: [Canonical.Def] -> State (Set.Set String) [(Canonical.Def, Int, [Int])]+buildDefDict+ :: [Canonical.Def]+ -> State (Set.Set String) [(Canonical.Def, Int, [Int])] buildDefDict defs =- do pdefsDeps <- mapM reorderAndGetDependencies defs- return $ realDeps (addKey pdefsDeps)-+ do pdefsDeps <- mapM reorderAndGetDependencies defs+ return $ realDeps (addKey pdefsDeps) where addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]- addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]+ addKey =+ zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..] variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)] variableToKey (Canonical.Definition pattern _ _, key, _) =@@ -163,8 +194,9 @@ Map.fromList (concatMap variableToKey pdefsDeps) realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]- realDeps pdefsDeps = map convert pdefsDeps- where- varDict = variableToKeyMap pdefsDeps- convert (pdef, key, deps) =- (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)+ realDeps pdefsDeps =+ map convert pdefsDeps+ where+ varDict = variableToKeyMap pdefsDeps+ convert (pdef, key, deps) =+ (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
src/Transform/Substitute.hs view
@@ -5,7 +5,7 @@ import qualified Data.Set as Set import AST.Annotation-import AST.Expression.General (Expr'(..))+import AST.Expression.General (Expr'(..), PortImpl(..)) import qualified AST.Expression.Canonical as Canonical import qualified AST.Pattern as Pattern import qualified AST.Variable as V@@ -77,12 +77,20 @@ Record fields -> Record (map (second f) fields) - Literal _ -> expression+ Literal _ ->+ expression - GLShader _ _ _ -> expression+ GLShader _ _ _ ->+ expression - PortIn name st ->- PortIn name st+ Port impl ->+ Port $+ case impl of+ In _ _ ->+ impl - PortOut name st signal ->- PortOut name st (f signal)+ Out name expr tipe ->+ Out name (f expr) tipe++ Task name expr tipe ->+ Task name (f expr) tipe
src/Type/Constrain/Expression.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wall #-} module Type.Constrain.Expression where import Control.Applicative ((<$>))@@ -5,9 +6,10 @@ import Control.Monad.Error import qualified Data.List as List import qualified Data.Map as Map+import Prelude hiding (and) import qualified Text.PrettyPrint as PP -import AST.Literal as Lit+import qualified AST.Literal as Lit import AST.Annotation as Ann import AST.Expression.General import qualified AST.Expression.Canonical as Canonical@@ -15,7 +17,7 @@ import qualified AST.Type as ST import qualified AST.Variable as V import Type.Type hiding (Descriptor(..))-import Type.Fragment+import qualified Type.Fragment as Fragment import qualified Type.Environment as Env import qualified Type.Constrain.Literal as Literal import qualified Type.Constrain.Pattern as Pattern@@ -26,7 +28,7 @@ -> Canonical.Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint-constrain env (A region expr) tipe =+constrain env (A region expression) tipe = let list t = Env.get env Env.types "List" <| t and = A region . CAnd true = A region CTrue@@ -34,16 +36,17 @@ x <? t = A region (CInstance x t) clet schemes c = A region (CLet schemes c) in- case expr of- Literal lit -> liftIO $ Literal.constrain env region lit tipe+ case expression of+ Literal lit ->+ liftIO $ Literal.constrain env region lit tipe - GLShader _uid _src gltipe -> - exists $ \attr -> - exists $ \unif -> - let + GLShader _uid _src gltipe ->+ exists $ \attr ->+ exists $ \unif ->+ let shaderTipe a u v = Env.get env Env.types "WebGL.Shader" <| a <| u <| v glTipe = Env.get env Env.types . Lit.glTipeName- makeRec accessor baseRec = + makeRec accessor baseRec = let decls = accessor gltipe in if Map.size decls == 0 then baseRec@@ -51,7 +54,8 @@ attribute = makeRec Lit.attribute attr uniform = makeRec Lit.uniform unif varying = makeRec Lit.varying (termN EmptyRecord1)- in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)+ in+ return . A region $ CEqual tipe (shaderTipe attribute uniform varying) Var var | name == saveEnvName -> return (A region CSaveEnv)@@ -60,167 +64,143 @@ name = V.toString var Range lo hi ->- existsNumber $ \n -> do- clo <- constrain env lo n- chi <- constrain env hi n- return $ and [clo, chi, list n === tipe]+ existsNumber $ \n ->+ do clo <- constrain env lo n+ chi <- constrain env hi n+ return $ and [clo, chi, list n === tipe] ExplicitList exprs ->- exists $ \x -> do- cs <- mapM (\e -> constrain env e x) exprs- return . and $ list x === tipe : cs+ exists $ \x ->+ do constraints <- mapM (\e -> constrain env e x) exprs+ return . and $ list x === tipe : constraints Binop op e1 e2 -> exists $ \t1 ->- exists $ \t2 -> do- c1 <- constrain env e1 t1- c2 <- constrain env e2 t2- return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]+ exists $ \t2 ->+ do c1 <- constrain env e1 t1+ c2 <- constrain env e2 t2+ return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ] Lambda p e -> exists $ \t1 ->- exists $ \t2 -> do- fragment <- try region $ Pattern.constrain env p t1- c2 <- constrain env e t2- let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]- (typeConstraint fragment /\ c2 ))- return $ c /\ tipe === (t1 ==> t2)+ exists $ \t2 ->+ do fragment <- try region $ Pattern.constrain env p t1+ c2 <- constrain env e t2+ let c = ex (Fragment.vars fragment)+ (clet [monoscheme (Fragment.typeEnv fragment)]+ (Fragment.typeConstraint fragment /\ c2)+ )+ return $ c /\ tipe === (t1 ==> t2) App e1 e2 ->- exists $ \t -> do- c1 <- constrain env e1 (t ==> tipe)- c2 <- constrain env e2 t- return $ c1 /\ c2+ exists $ \t ->+ do c1 <- constrain env e1 (t ==> tipe)+ c2 <- constrain env e2 t+ return $ c1 /\ c2 - MultiIf branches -> and <$> mapM constrain' branches- where - bool = Env.get env Env.types "Bool"- constrain' (b,e) = do- cb <- constrain env b bool- ce <- constrain env e tipe+ MultiIf branches ->+ and <$> mapM constrain' branches+ where+ bool = Env.get env Env.types "Bool"++ constrain' (cond, expr) =+ do cb <- constrain env cond bool+ ce <- constrain env expr tipe return (cb /\ ce) - Case exp branches ->- exists $ \t -> do- ce <- constrain env exp t- let branch (p,e) = do- fragment <- try region $ Pattern.constrain env p t- clet [toScheme fragment] <$> constrain env e tipe- and . (:) ce <$> mapM branch branches+ Case expr branches ->+ exists $ \t ->+ do ce <- constrain env expr t+ and . (:) ce <$> mapM (branch t) branches+ where+ branch t (pattern, branchExpr) =+ do fragment <- try region $ Pattern.constrain env pattern t+ clet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe Data name exprs ->- do vars <- forM exprs $ \_ -> liftIO (variable Flexible)- let pairs = zip exprs (map varN vars)- (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)- return $ ex vars (cs /\ name <? ctipe)+ do vars <- forM exprs $ \_ -> liftIO (variable Flexible)+ let pairs = zip exprs (map varN vars)+ (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)+ return $ ex vars (cs /\ name <? ctipe) where- step (t,c) (e,x) = do- c' <- constrain env e x- return (x ==> t, c /\ c')+ step (t,c) (e,x) =+ do c' <- constrain env e x+ return (x ==> t, c /\ c') - Access e label ->+ Access expr label -> exists $ \t ->- constrain env e (record (Map.singleton label [tipe]) t)+ constrain env expr (record (Map.singleton label [tipe]) t) - Remove e label ->+ Remove expr label -> exists $ \t ->- constrain env e (record (Map.singleton label [t]) tipe)+ constrain env expr (record (Map.singleton label [t]) tipe) - Insert e label value ->+ Insert expr label value -> exists $ \tVal ->- exists $ \tRec -> do- cVal <- constrain env value tVal- cRec <- constrain env e tRec- let c = tipe === record (Map.singleton label [tVal]) tRec- return (and [cVal, cRec, c])+ exists $ \tRec ->+ do cVal <- constrain env value tVal+ cRec <- constrain env expr tRec+ let c = tipe === record (Map.singleton label [tVal]) tRec+ return (and [cVal, cRec, c]) - Modify e fields ->- exists $ \t -> do- oldVars <- forM fields $ \_ -> liftIO (variable Flexible)- let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))- cOld <- ex oldVars <$> constrain env e (record oldFields t)+ Modify expr fields ->+ exists $ \t ->+ do oldVars <- forM fields $ \_ -> liftIO (variable Flexible)+ let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))+ cOld <- ex oldVars <$> constrain env expr (record oldFields t) - newVars <- forM fields $ \_ -> liftIO (variable Flexible)- let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))- let cNew = tipe === record newFields t+ newVars <- forM fields $ \_ -> liftIO (variable Flexible)+ let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))+ let cNew = tipe === record newFields t - cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)+ cs <- zipWithM (constrain env) (map snd fields) (map varN newVars) - return $ cOld /\ ex newVars (and (cNew : cs))+ return $ cOld /\ ex newVars (and (cNew : cs)) Record fields ->- do vars <- forM fields $ \_ -> liftIO (variable Flexible)- cs <- zipWithM (constrain env) (map snd fields) (map varN vars)- let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))- recordType = record fields' (termN EmptyRecord1)- return . ex vars . and $ tipe === recordType : cs+ do vars <- forM fields $ \_ -> liftIO (variable Flexible)+ cs <- zipWithM (constrain env) (map snd fields) (map varN vars)+ let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))+ let recordType = record fields' (termN EmptyRecord1)+ return . ex vars . and $ tipe === recordType : cs Let defs body ->- do c <- constrain env body tipe- (schemes, rqs, fqs, header, c2, c1) <-- Monad.foldM (constrainDef env)- ([], [], [], Map.empty, true, true)- (concatMap expandPattern defs)- return $ clet schemes- (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]- (c1 /\ c))+ do c <- constrain env body tipe - PortIn _ _ -> return true+ (Info schemes rqs fqs headers c2 c1) <-+ Monad.foldM+ (constrainDef env)+ (Info [] [] [] Map.empty true true)+ (concatMap expandPattern defs) - PortOut _ _ signal ->- constrain env signal tipe+ let letScheme = [ Scheme rqs fqs (clet [monoscheme headers] c2) headers ] + return $ clet schemes (clet letScheme (c1 /\ c)) -constrainDef env info (Canonical.Definition pattern expr maybeTipe) =- let qs = [] -- should come from the def, but I'm not sure what would live there...- (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info- in- do rigidVars <- forM qs (\_ -> liftIO $ variable Rigid) -- Some mistake may be happening here.- -- Currently, qs is always [].- case (pattern, maybeTipe) of- (P.Var name, Just tipe) -> do- flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)- let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars- env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }- (vars, typ) <- Env.instantiateType env tipe Map.empty- let scheme = Scheme { rigidQuantifiers = [],- flexibleQuantifiers = flexiVars ++ vars,- constraint = Ann.noneNoDocs CTrue,- header = Map.singleton name typ }- c <- constrain env' expr typ- return ( scheme : schemes- , rigidQuantifiers- , flexibleQuantifiers- , headers- , c2- , fl rigidVars c /\ c1 )+ Port impl ->+ case impl of+ In _ _ ->+ return true - (P.Var name, Nothing) -> do- v <- liftIO $ variable Flexible- let tipe = varN v- inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars- env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }- c <- constrain env' expr tipe- return ( schemes- , rigidVars ++ rigidQuantifiers- , v : flexibleQuantifiers- , Map.insert name tipe headers- , c /\ c2- , c1 )+ Out _ expr _ ->+ constrain env expr tipe - _ -> error ("problem in constrainDef with " ++ show pattern)+ Task _ expr _ ->+ constrain env expr tipe expandPattern :: Canonical.Def -> [Canonical.Def] expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) = case pattern of- P.Var _ -> [def]- _ -> Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars- where- vars = P.boundVarList pattern- x = "$" ++ concat vars- mkVar = A r . localVar- toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing+ P.Var _ ->+ [def]+ _ ->+ Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars+ where+ vars = P.boundVarList pattern+ x = "$" ++ concat vars+ mkVar = A r . localVar+ toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a@@ -229,3 +209,94 @@ case result of Left err -> throwError [err region] Right value -> return value+++-- CONSTRAIN DEFINITIONS++data Info = Info+ { iSchemes :: [TypeScheme]+ , iRigid :: [Variable]+ , iFlex :: [Variable]+ , iHeaders :: Map.Map String Type+ , iC2 :: TypeConstraint+ , iC1 :: TypeConstraint+ }+++constrainDef :: Env.Environment -> Info -> Canonical.Def -> ErrorT [PP.Doc] IO Info+constrainDef env info (Canonical.Definition pattern expr maybeTipe) =+ let qs = [] -- should come from the def, but I'm not sure what would live there...+ in+ case (pattern, maybeTipe) of+ (P.Var name, Just tipe) ->+ constrainAnnotatedDef env info qs name expr tipe++ (P.Var name, Nothing) ->+ constrainUnannotatedDef env info qs name expr++ _ -> error ("problem in constrainDef with " ++ show pattern)+++constrainAnnotatedDef+ :: Env.Environment+ -> Info+ -> [String]+ -> String+ -> Canonical.Expr+ -> ST.CanonicalType+ -> ErrorT [PP.Doc] IO Info+constrainAnnotatedDef env info qs name expr tipe =+ do -- Some mistake may be happening here. Currently, qs is always [].+ rigidVars <- forM qs (\_ -> liftIO $ variable Rigid)++ flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)++ let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars++ let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }++ (vars, typ) <- Env.instantiateType env tipe Map.empty++ let scheme =+ Scheme+ { rigidQuantifiers = []+ , flexibleQuantifiers = flexiVars ++ vars+ , constraint = Ann.noneNoDocs CTrue+ , header = Map.singleton name typ+ }++ c <- constrain env' expr typ++ return $ info+ { iSchemes = scheme : iSchemes info+ , iC1 = fl rigidVars c /\ iC1 info+ }+++constrainUnannotatedDef+ :: Env.Environment+ -> Info+ -> [String]+ -> String+ -> Canonical.Expr+ -> ErrorT [PP.Doc] IO Info+constrainUnannotatedDef env info qs name expr =+ do -- Some mistake may be happening here. Currently, qs is always [].+ rigidVars <- forM qs (\_ -> liftIO $ variable Rigid)++ v <- liftIO $ variable Flexible++ let tipe = varN v++ let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars++ let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }++ c <- constrain env' expr tipe++ return $ info+ { iRigid = rigidVars ++ iRigid info+ , iFlex = v : iFlex info+ , iHeaders = Map.insert name tipe (iHeaders info)+ , iC2 = c /\ iC2 info+ }
src/Type/Environment.hs view
@@ -7,6 +7,7 @@ import qualified Control.Monad.State as State import qualified Data.Traversable as Traverse import qualified Data.Map as Map+import qualified Data.Set as Set import Data.List (isPrefixOf) import qualified Text.PrettyPrint as PP @@ -15,153 +16,220 @@ import AST.Module (CanonicalAdt, AdtInfo) import Type.Type + type TypeDict = Map.Map String Type type VarDict = Map.Map String Variable + data Environment = Environment { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)) , types :: TypeDict , value :: TypeDict } + initialEnvironment :: [CanonicalAdt] -> IO Environment-initialEnvironment datatypes = do- types <- makeTypes datatypes- let env = Environment+initialEnvironment datatypes =+ do types <- makeTypes datatypes+ let env =+ Environment { constructor = Map.empty , value = Map.empty , types = types }- return $ env { constructor = makeConstructors env datatypes }+ return $ env { constructor = makeConstructors env datatypes } + makeTypes :: [CanonicalAdt] -> IO TypeDict makeTypes datatypes =- do adts <- mapM makeImported datatypes- bs <- mapM makeBuiltin builtins- return (Map.fromList (adts ++ bs))+ do adts <- mapM makeImported datatypes+ bs <- mapM makeBuiltin builtins+ return (Map.fromList (adts ++ bs)) where makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)- makeImported (var, _) = do- tvar <- namedVar Constant var- return (V.toString var, varN tvar)+ makeImported (var, _) =+ do tvar <- namedVar Constant var+ return (V.toString var, varN tvar) makeBuiltin :: (String, Int) -> IO (String, Type)- makeBuiltin (name, _) = do- name' <- namedVar Constant (V.builtin name)- return (name, varN name')+ makeBuiltin (name, _) =+ do name' <- namedVar Constant (V.builtin name)+ return (name, varN name') builtins :: [(String, Int)]- builtins = concat [ map tuple [0..9]- , kind 1 ["List"]- , kind 0 ["Int","Float","Char","String","Bool"]- ]+ builtins =+ concat+ [ map tuple [0..9]+ , kind 1 ["List"]+ , kind 0 ["Int","Float","Char","String","Bool"]+ ] where tuple n = ("_Tuple" ++ show n, n) kind n names = map (\name -> (name, n)) names --makeConstructors :: Environment- -> [CanonicalAdt]- -> Map.Map String (IO (Int, [Variable], [Type], Type))-makeConstructors env datatypes = Map.fromList builtins+makeConstructors+ :: Environment+ -> [CanonicalAdt]+ -> Map.Map String (IO (Int, [Variable], [Type], Type))+makeConstructors env datatypes =+ Map.fromList builtins where- list t = (types env Map.! "List") <| t+ list t =+ (types env Map.! "List") <| t inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)- inst numTVars tipe = do- vars <- forM [1..numTVars] $ \_ -> variable Flexible- let (args, result) = tipe (map (varN) vars)- return (length args, vars, args, result)+ inst numTVars tipe =+ do vars <- forM [1..numTVars] $ \_ -> variable Flexible+ let (args, result) = tipe (map (varN) vars)+ return (length args, vars, args, result) tupleCtor n = let name = "_Tuple" ++ show n in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))- + builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]- builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))- , ("::", inst 1 $ \ [t] -> ([t, list t], list t))- ] ++ map tupleCtor [0..9]- ++ concatMap (ctorToType env) datatypes+ builtins =+ [ ("[]", inst 1 $ \ [t] -> ([], list t))+ , ("::", inst 1 $ \ [t] -> ([t, list t], list t))+ ] ++ map tupleCtor [0..9]+ ++ concatMap (ctorToType env) datatypes -ctorToType :: Environment- -> (V.Canonical, AdtInfo V.Canonical)- -> [(String, IO (Int, [Variable], [Type], Type))]+ctorToType+ :: Environment+ -> (V.Canonical, AdtInfo V.Canonical)+ -> [(String, IO (Int, [Variable], [Type], Type))] ctorToType env (name, (tvars, ctors)) = zip (map (V.toString . fst) ctors) (map inst ctors) where inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)- inst ctor = do- ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty- return (length args, Map.elems dict, args, tipe)- + inst ctor =+ do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty+ return (length args, Map.elems dict, args, tipe) + go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)- go (_, args) = do- types <- mapM (instantiator env) args- returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))- return (types, returnType)+ go (_, args) =+ do types <- mapM (instantiator env) args+ returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))+ return (types, returnType) get :: Environment -> (Environment -> Map.Map String a) -> String -> a-get env subDict key = Map.findWithDefault (error msg) key (subDict env)+get env subDict key =+ Map.findWithDefault (error msg) key (subDict env) where msg = "Could not find type constructor '" ++ key ++ "' while checking types." -freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)-freshDataScheme env name = get env constructor name+freshDataScheme+ :: Environment+ -> String+ -> IO (Int, [Variable], [Type], Type)+freshDataScheme env name =+ get env constructor name -instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)++instantiateType+ :: Environment+ -> T.CanonicalType+ -> VarDict+ -> ErrorT [PP.Doc] IO ([Variable], Type) instantiateType env sourceType dict =- do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)- case result :: Either SomeException (Type, VarDict) of- Left someError -> throwError [ PP.text $ show someError ]- Right (tipe, dict') -> return (Map.elems dict', tipe)+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)+ case result :: Either SomeException (Type, VarDict) of+ Left someError ->+ throwError [ PP.text $ show someError ] -instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type-instantiator env sourceType = go sourceType- where- go :: T.CanonicalType -> State.StateT VarDict IO Type- go sourceType =- case sourceType of- T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2+ Right (tipe, dict') ->+ return (Map.elems dict', tipe) - T.Var x -> do- dict <- State.get- case Map.lookup x dict of- Just v -> return (varN v)- Nothing ->- do v <- State.liftIO $ namedVar flex (V.local x)- State.put (Map.insert x v dict)- return (varN v)- where- flex | "number" `isPrefixOf` x = Is Number- | "comparable" `isPrefixOf` x = Is Comparable- | "appendable" `isPrefixOf` x = Is Appendable- | otherwise = Flexible - T.Aliased name t -> do- t' <- go t- case t' of- VarN _ v -> return (VarN (Just name) v)- TermN _ term -> return (TermN (Just name) term)+instantiator+ :: Environment+ -> T.CanonicalType+ -> State.StateT VarDict IO Type+instantiator env sourceType =+ instantiatorHelp env Set.empty sourceType - T.Type name ->++instantiatorHelp+ :: Environment+ -> Set.Set String+ -> T.CanonicalType+ -> State.StateT VarDict IO Type+instantiatorHelp env aliasVars sourceType =+ let go = instantiatorHelp env aliasVars+ in+ case sourceType of+ T.Lambda t1 t2 ->+ (==>) <$> go t1 <*> go t2++ T.Var x ->+ do dict <- State.get+ case Set.member x aliasVars of+ True ->+ return (PlaceHolder x)+ False ->+ case Map.lookup x dict of+ Just v ->+ return (varN v)++ Nothing ->+ do v <- State.liftIO $ namedVar flex (V.local x)+ State.put (Map.insert x v dict)+ return (varN v)+ where+ flex | "number" `isPrefixOf` x = Is Number+ | "comparable" `isPrefixOf` x = Is Comparable+ | "appendable" `isPrefixOf` x = Is Appendable+ | otherwise = Flexible++ T.Aliased name args aliasType ->+ do args' <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args+ aliasedType' <-+ case aliasType of+ T.Filled tipe ->+ instantiatorHelp env Set.empty tipe+ T.Holey tipe ->+ instantiatorHelp env (Set.fromList (map fst args)) tipe++ case aliasedType' of+ PlaceHolder _ ->+ error "problem instantiating type"++ VarN maybeSubAlias v ->+ case maybeSubAlias of+ Nothing ->+ return (VarN (Just (name,args')) v)+ Just _subAlias ->+ return (TermN (Just (name,args')) (Var1 aliasedType'))++ TermN maybeSubAlias t ->+ case maybeSubAlias of+ Nothing ->+ return (TermN (Just (name, args')) t)+ Just _subAlias ->+ return (TermN (Just (name,args')) (Var1 aliasedType'))++ T.Type name -> case Map.lookup (V.toString name) (types env) of Just t -> return t- Nothing -> error $ "Could not find type constructor '" ++- V.toString name ++ "' while checking types."+ Nothing ->+ error $+ "Could not find type constructor '" +++ V.toString name ++ "' while checking types." - T.App t ts -> do- t' <- go t- ts' <- mapM go ts- return $ foldl (<|) t' ts'+ T.App t ts ->+ do t' <- go t+ ts' <- mapM go ts+ return $ foldl (<|) t' ts' - T.Record fields ext -> do- fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)- ext' <- case ext of+ T.Record fields ext ->+ do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)+ ext' <-+ case ext of Nothing -> return $ termN EmptyRecord1 Just x -> go x- return $ termN (Record1 fields' ext')+ return $ termN (Record1 fields' ext')
src/Type/ExtraChecks.hs view
@@ -4,8 +4,9 @@ successfully. At that point we still need to do occurs checks and ensure that `main` has an acceptable type. -}-module Type.ExtraChecks (mainType, occurs, portTypes) where+module Type.ExtraChecks (effectTypes, occurs) where +import Prelude hiding (maybe) import Control.Applicative ((<$>),(<*>)) import Control.Monad.Error import Control.Monad.State@@ -15,129 +16,101 @@ import Text.PrettyPrint as P import qualified AST.Annotation as A-import qualified AST.Expression.Canonical as Canonical import qualified AST.PrettyPrint as PP import qualified AST.Type as ST-import qualified AST.Variable as V-import qualified Transform.Expression as Expr+import qualified AST.Variable as Var import qualified Type.Hint as Hint import qualified Type.Type as TT import qualified Type.State as TS -throw :: [Doc] -> Either [Doc] a-throw err =- Left [ P.vcat err ]-+-- EFFECT TYPE CHECKS -mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)-mainType environment =+effectTypes :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)+effectTypes environment = do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment mainCheck environment'- where- mainCheck- :: (Monad m) => Map.Map String ST.CanonicalType- -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)- mainCheck env =- case Map.lookup "main" env of- Nothing -> return env- Just typeOfMain- | tipe `elem` acceptable -> return env- | otherwise -> throwError [ err ]- where- acceptable =- [ "Graphics.Element.Element"- , "Signal.Signal Graphics.Element.Element"- , "Html.Html"- , "Signal.Signal Html.Html"- ]+ return environment' - tipe = PP.renderPretty typeOfMain - err =- P.vcat- [ P.text "Type Error: 'main' must have one of the following types:"- , P.text " "- , P.text " Element, Html, Signal Element, Signal Html"- , P.text " "- , P.text "Instead 'main' has type:\n"- , P.nest 4 (PP.pretty typeOfMain)- , P.text " "- ]+-- MAIN TYPE +mainCheck+ :: (Monad m)+ => Map.Map String ST.CanonicalType+ -> ErrorT [P.Doc] m ()+mainCheck env =+ case Map.lookup "main" env of+ Nothing ->+ return () -data Direction = In | Out+ Just typeOfMain ->+ let tipe = ST.deepDealias typeOfMain+ in+ if tipe `elem` validMainTypes+ then return ()+ else throwError [ badMainMessage typeOfMain ] -portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()-portTypes expr =- case Expr.checkPorts (check In) (check Out) expr of- Left err -> throwError err- Right _ -> return ()+validMainTypes :: [ST.CanonicalType]+validMainTypes =+ [ element+ , html+ , signal element+ , signal html+ ] where- check = isValid True False False- isValid isTopLevel seenFunc seenSignal direction name tipe =- case tipe of- ST.Aliased _ t -> valid t+ fromModule :: [String] -> String -> ST.CanonicalType+ fromModule home name =+ ST.Type (Var.fromModule home name) - ST.Type v ->- case any ($ v) [ V.isJson, V.isPrimitive, V.isTuple ] of- True -> return ()- False -> err "an unsupported type"+ html =+ fromModule ["VirtualDom"] "Node" - ST.App t [] -> valid t+ signal tipe =+ ST.App (fromModule ["Signal"] "Signal") [ tipe ] - ST.App (ST.Type v) [t]- | V.isSignal v -> handleSignal t- | V.isMaybe v -> valid t- | V.isArray v -> valid t- | V.isList v -> valid t+ element =+ let builtin name =+ ST.Type (Var.builtin name) - ST.App (ST.Type v) ts- | V.isTuple v -> mapM_ valid ts- - ST.App _ _ -> err "an unsupported type"+ maybe tipe =+ ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]+ in+ ST.Record+ [ ("element", fromModule ["Graphics","Element"] "ElementPrim")+ , ("props",+ ST.Record+ [ ("click" , builtin "_Tuple0")+ , ("color" , maybe (fromModule ["Color"] "Color"))+ , ("height" , builtin "Int")+ , ("hover" , builtin "_Tuple0")+ , ("href" , builtin "String")+ , ("id" , builtin "Int")+ , ("opacity", builtin "Float")+ , ("tag" , builtin "String")+ , ("width" , builtin "Int")+ ]+ Nothing+ )+ ]+ Nothing - ST.Var _ -> err "free type variables" - ST.Lambda _ _ ->- case direction of- In -> err "functions"- Out | seenFunc -> err "higher-order functions"- | seenSignal -> err "signals that contain functions"- | otherwise ->- forM_ (ST.collectLambdas tipe)- (isValid' True seenSignal direction name)+badMainMessage :: ST.CanonicalType -> P.Doc+badMainMessage typeOfMain =+ P.vcat+ [ P.text "Type Error: 'main' must have one of the following types:"+ , P.text " "+ , P.text " Element, Html, Signal Element, Signal Html"+ , P.text " "+ , P.text "Instead 'main' has type:\n"+ , P.nest 4 (PP.pretty typeOfMain)+ , P.text " "+ ] - ST.Record _ (Just _) -> err "extended records with free type variables" - ST.Record fields Nothing ->- mapM_ (\(k,v) -> (,) k <$> valid v) fields-- where- isValid' = isValid False- valid = isValid' seenFunc seenSignal direction name-- handleSignal t- | seenFunc = err "functions that involve signals"- | seenSignal = err "signals-of-signals"- | isTopLevel = isValid' seenFunc True direction name t- | otherwise = err "a signal within a data stucture"-- dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }- txt = P.text . concat-- err kind =- throw $- [ txt [ "Type Error: the value ", dir "coming in" "sent out"- , " through port '", name, "' is invalid." ]- , txt [ "It contains ", kind, ":\n" ]- , P.nest 4 (PP.pretty tipe) <> P.text "\n"- , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]- , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]- , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]- ]-+-- INFINITE TYPES occurs :: (String, TT.Variable) -> StateT TS.SolverState IO () occurs (name, variable) =@@ -171,8 +144,17 @@ Nothing -> return [] Just struct -> case struct of- TT.App1 a b -> (++) <$> go a <*> go b- TT.Fun1 a b -> (++) <$> go a <*> go b- TT.Var1 a -> go a- TT.EmptyRecord1 -> return []- TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))+ TT.App1 a b ->+ (++) <$> go a <*> go b++ TT.Fun1 a b ->+ (++) <$> go a <*> go b++ TT.Var1 a ->+ go a++ TT.EmptyRecord1 ->+ return []++ TT.Record1 fields ext ->+ concat <$> mapM go (ext : concat (Map.elems fields))
src/Type/Inference.hs view
@@ -33,12 +33,10 @@ hints@(_:_) -> throwError hints [] -> return () - () <- Check.portTypes (program (body modul))- let header' = Map.delete "::" header types = Map.difference (TS.sSavedEnv state) header' - Check.mainType types+ Check.effectTypes types genConstraints
src/Type/State.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} module Type.State where -import Control.Applicative ( (<$>), (<*>), Applicative, (<|>) )+import Control.Applicative ( Applicative, (<$>), (<*>), (<|>) ) import Control.Monad.State+import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Traversable as Traversable import qualified Data.UnionFind.IO as UF@@ -119,26 +120,47 @@ flatten :: Type -> StateT SolverState IO Variable flatten term =+ flattenHelp Map.empty term+++flattenHelp :: Map.Map String Variable -> Type -> StateT SolverState IO Variable+flattenHelp aliasDict term = case term of+ PlaceHolder name ->+ return (aliasDict ! name)+ VarN maybeAlias v ->- do liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc }+ do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias+ liftIO $ UF.modifyDescriptor v $ \desc ->+ desc { alias = maybeAlias' <|> alias desc } return v - TermN maybeAlias t ->- do flatStructure <- traverseTerm flatten t+ TermN maybeAlias subTerm ->+ do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias+ let localDict = maybe aliasDict (Map.fromList . snd) maybeAlias'+ flatStructure <- traverseTerm (flattenHelp localDict) subTerm pool <- getPool- var <- liftIO . UF.fresh $ Descriptor- { structure = Just flatStructure- , rank = maxRank pool- , flex = Flexible- , name = Nothing- , copy = Nothing- , mark = noMark- , alias = maybeAlias- }+ var <-+ liftIO . UF.fresh $ Descriptor+ { structure = Just flatStructure+ , rank = maxRank pool+ , flex = Flexible+ , name = Nothing+ , copy = Nothing+ , mark = noMark+ , alias = maybeAlias'+ } register var+ where+ flattenAlias (name, args) =+ let flattenPair (arg, subTerm) =+ (,) arg <$> flattenHelp aliasDict subTerm+ in+ (,) name <$> mapM flattenPair args ++ makeInstance :: Variable -> StateT SolverState IO Variable makeInstance var = do alreadyCopied <- uniqueMark@@ -151,52 +173,60 @@ makeCopy alreadyCopied variable = do desc <- liftIO $ UF.descriptor variable case () of- () | mark desc == alreadyCopied ->- case copy desc of- Just v -> return v- Nothing -> error $ "Error copying type variable. This should be impossible." ++- " Please report an error to the github repo!"+ () | mark desc == alreadyCopied ->+ case copy desc of+ Just v ->+ return v+ Nothing ->+ error $+ "Error copying type variable. This should be impossible." +++ " Please report an error to the github repo!" - | rank desc /= noRank || flex desc == Constant ->- return variable+ | rank desc /= noRank || flex desc == Constant ->+ return variable - | otherwise -> do- pool <- getPool- newVar <- liftIO $ UF.fresh $ Descriptor- { structure = Nothing- , rank = maxRank pool- , mark = noMark- , flex = case flex desc of- Is s -> Is s- _ -> Flexible- , copy = Nothing- , name = case flex desc of- Rigid -> Nothing- _ -> name desc- , alias = Nothing- }- register newVar+ | otherwise ->+ do pool <- getPool+ newVar <-+ liftIO $ UF.fresh $ Descriptor+ { structure = Nothing+ , rank = maxRank pool+ , mark = noMark+ , flex =+ case flex desc of+ Is s -> Is s+ _ -> Flexible+ , copy = Nothing+ , name =+ case flex desc of+ Rigid -> Nothing+ _ -> name desc+ , alias = Nothing+ }+ register newVar - -- Link the original variable to the new variable. This lets us- -- avoid making multiple copies of the variable we are instantiating.- --- -- Need to do this before recursively copying the structure of- -- the variable to avoid looping on cyclic terms.- liftIO $ UF.modifyDescriptor variable $ \desc ->- desc { mark = alreadyCopied, copy = Just newVar }+ -- Link the original variable to the new variable. This lets us+ -- avoid making multiple copies of the variable we are instantiating.+ --+ -- Need to do this before recursively copying the structure of+ -- the variable to avoid looping on cyclic terms.+ liftIO $ UF.modifyDescriptor variable $ \desc ->+ desc { mark = alreadyCopied, copy = Just newVar } - -- Now we recursively copy the structure of the variable.- -- We have already marked the variable as copied, so we- -- will not repeat this work or crawl this variable again.- case structure desc of- Nothing -> return newVar- Just term -> do- newTerm <- traverseTerm (makeCopy alreadyCopied) term- liftIO $ UF.modifyDescriptor newVar $ \desc ->- desc { structure = Just newTerm }- return newVar+ -- Now we recursively copy the structure of the variable.+ -- We have already marked the variable as copied, so we+ -- will not repeat this work or crawl this variable again.+ case structure desc of+ Nothing ->+ return newVar + Just term ->+ do newTerm <- traverseTerm (makeCopy alreadyCopied) term+ liftIO $ UF.modifyDescriptor newVar $ \desc ->+ desc { structure = Just newTerm }+ return newVar + restore :: Int -> Variable -> StateT SolverState IO Variable restore alreadyCopied variable = do desc <- liftIO $ UF.descriptor variable@@ -213,10 +243,19 @@ traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b) traverseTerm f term = case term of- App1 a b -> App1 <$> f a <*> f b- Fun1 a b -> Fun1 <$> f a <*> f b- Var1 x -> Var1 <$> f x- EmptyRecord1 -> return EmptyRecord1- Record1 fields ext ->- Record1 <$> Traversable.traverse (mapM f) fields <*> f ext+ App1 a b ->+ App1 <$> f a <*> f b + Fun1 a b ->+ Fun1 <$> f a <*> f b++ Var1 x ->+ Var1 <$> f x++ EmptyRecord1 ->+ return EmptyRecord1++ Record1 fields ext ->+ Record1+ <$> Traversable.traverse (mapM f) fields+ <*> f ext
src/Type/Type.hs view
@@ -1,22 +1,39 @@ module Type.Type where +import Control.Applicative ((<$>),(<*>))+import Control.Monad.State (StateT)+import qualified Control.Monad.State as State+import Control.Monad.Error (ErrorT, Error, liftIO) import qualified Data.Char as Char-import qualified Data.List as List import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Traversable as Traverse (traverse) import qualified Data.UnionFind.IO as UF-import Type.PrettyPrint import Text.PrettyPrint as P import System.IO.Unsafe-import Control.Applicative ((<$>),(<*>))-import Control.Monad.State (StateT, get, put, execStateT, runStateT)-import Control.Monad.Error (ErrorT, Error, liftIO)-import Data.Traversable (traverse)+ import AST.Annotation import qualified AST.PrettyPrint as PP import qualified AST.Type as T import qualified AST.Variable as Var+import Type.PrettyPrint +-- CONCRETE TYPES++type Type = TermN Variable++type Variable = UF.Point Descriptor++type TypeConstraint = Constraint Type Variable++type TypeScheme = Scheme Type Variable++type Alias a = Maybe (Var.Canonical, [(String,a)])+++-- TYPE PRIMITIVES+ data Term1 a = App1 a a | Fun1 a a@@ -26,37 +43,69 @@ data TermN a- = VarN (Maybe Var.Canonical) a- | TermN (Maybe Var.Canonical) (Term1 (TermN a))+ = PlaceHolder String+ | VarN (Alias (TermN a)) a+ | TermN (Alias (TermN a)) (Term1 (TermN a)) varN :: a -> TermN a-varN = VarN Nothing+varN =+ VarN Nothing termN :: (Term1 (TermN a)) -> TermN a-termN = TermN Nothing+termN =+ TermN Nothing record :: Map.Map String [TermN a] -> TermN a -> TermN a-record fs rec = termN (Record1 fs rec)+record fs rec =+ termN (Record1 fs rec) -type Type = TermN Variable+-- DESCRIPTORS +data Descriptor = Descriptor+ { structure :: Maybe (Term1 Variable)+ , rank :: Int+ , flex :: Flex+ , name :: Maybe TypeName+ , copy :: Maybe Variable+ , mark :: Int+ , alias :: Alias Variable+ } -type Variable = UF.Point Descriptor+noRank :: Int+noRank = -1 +outermostRank :: Int+outermostRank = 0 -type SchemeName = String+noMark :: Int+noMark = 0 +initialMark :: Int+initialMark = 1 -type TypeName = Var.Canonical+data Flex+ = Rigid+ | Flexible+ | Constant+ | Is SuperType+ deriving (Eq) +data SuperType+ = Number+ | Comparable+ | Appendable+ deriving (Eq) -type Constraint a b = Located (BasicConstraint a b) +-- CONSTRAINTS +type Constraint a b =+ Located (BasicConstraint a b)+ data BasicConstraint a b = CTrue | CSaveEnv@@ -65,7 +114,10 @@ | CLet [Scheme a b] (Constraint a b) | CInstance SchemeName a +type SchemeName = String +type TypeName = Var.Canonical+ data Scheme a b = Scheme { rigidQuantifiers :: [b] , flexibleQuantifiers :: [b]@@ -74,76 +126,21 @@ } -type TypeConstraint = Constraint Type Variable--type TypeScheme = Scheme Type Variable---monoscheme :: Map.Map String a -> Scheme a b-monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers---infixl 8 /\--(/\) :: Constraint a b -> Constraint a b -> Constraint a b-a@(A _ c1) /\ b@(A _ c2) =- case (c1, c2) of- (CTrue, _) -> b- (_, CTrue) -> a- _ -> mergeOldDocs a b (CAnd [a,b])-+-- TYPE HELPERS infixr 9 ==> (==>) :: Type -> Type -> Type-a ==> b = termN (Fun1 a b)+(==>) a b =+ termN (Fun1 a b) (<|) :: TermN a -> TermN a -> TermN a-f <| a = termN (App1 f a)---data Descriptor = Descriptor- { structure :: Maybe (Term1 Variable)- , rank :: Int- , flex :: Flex- , name :: Maybe TypeName- , copy :: Maybe Variable- , mark :: Int- , alias :: Maybe Var.Canonical- }---noRank :: Int-noRank = -1---outermostRank :: Int-outermostRank = 0---noMark :: Int-noMark = 0---initialMark :: Int-initialMark = 1---data Flex- = Rigid- | Flexible- | Constant- | Is SuperType- deriving (Eq)+(<|) f a =+ termN (App1 f a) -data SuperType- = Number- | Comparable- | Appendable- deriving (Eq)-+-- VARIABLE HELPERS namedVar :: Flex -> Var.Canonical -> IO Variable namedVar flex name = UF.fresh $ Descriptor@@ -169,6 +166,23 @@ } +-- CONSTRAINT HELPERS++monoscheme :: Map.Map String a -> Scheme a b+monoscheme headers =+ Scheme [] [] (noneNoDocs CTrue) headers+++infixl 8 /\++(/\) :: Constraint a b -> Constraint a b -> Constraint a b+(/\) a@(A _ c1) b@(A _ c2) =+ case (c1, c2) of+ (CTrue, _) -> b+ (_, CTrue) -> a+ _ -> mergeOldDocs a b (CAnd [a,b])++ -- ex qs constraint == exists qs. constraint ex :: [Variable] -> TypeConstraint -> TypeConstraint ex fqs constraint@(A ann _) =@@ -213,54 +227,77 @@ parensIf needed (px <+> pretty App x) where px = prty f- needed = case when of- App -> True- _ -> False+ needed =+ case when of+ App -> True+ _ -> False Fun1 arg body -> parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body) where- needed = case when of- Never -> False- _ -> True+ needed =+ case when of+ Never -> False+ _ -> True - Var1 x -> prty x+ Var1 x ->+ prty x - EmptyRecord1 -> P.braces P.empty+ EmptyRecord1 ->+ P.braces P.empty Record1 fields ext -> P.braces (extend <+> commaSep prettyFields) where prettyExt = prty ext- extend | P.render prettyExt == "{}" = P.empty- | otherwise = prettyExt <+> P.text "|"- mkPretty f t = P.text f <+> P.text ":" <+> prty t- prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields) + extend+ | P.render prettyExt == "{}" =+ P.empty+ | otherwise =+ prettyExt <+> P.text "|" + mkPretty f t =+ P.text f <+> P.text ":" <+> prty t++ prettyFields =+ concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)++ instance PrettyType a => PrettyType (TermN a) where pretty when term = case term of- VarN alias x -> either alias (pretty when x)- TermN alias t1 -> either alias (pretty when t1)+ PlaceHolder _ ->+ error "problem prettifying type, probably indicates a bigger problem"++ VarN alias x ->+ either alias (pretty when x)++ TermN alias t1 ->+ either alias (pretty when t1) where either maybeAlias doc = case maybeAlias of- Just alias -> PP.pretty alias Nothing -> doc+ Just (name, args) ->+ P.hang (PP.pretty name) 2 (P.sep (map (pretty App . snd) args)) instance PrettyType Descriptor where- pretty when desc = do+ pretty when desc = case (alias desc, structure desc, name desc) of- (Just name, _, _) -> PP.pretty name- (_, Just term, _) -> pretty when term+ (Just (name, args), _, _) ->+ P.hang (PP.pretty name) 4 (P.sep (map (pretty App . snd) args))++ (_, Just term, _) ->+ pretty when term+ (_, _, Just name) | Var.isTuple name -> P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ',' | otherwise -> P.text (Var.toString name)- + _ -> P.text "?" @@ -319,180 +356,251 @@ prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t -extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc-extraPretty t = pretty Never <$> addNames t+-- CONVERT TO SOURCE TYPES +-- TODO: Attach resulting type to the descriptor so that you+-- never have to do extra work, particularly nice for aliased types+toSrcType :: Variable -> IO T.CanonicalType+toSrcType variable =+ do addNames variable+ variableToSrcType variable variable --- ADDING NAMES TO TYPES -addNames :: (Crawl t) => t -> IO t-addNames value = do- (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)- let vars = map head . List.group $ List.sort rawVars- suffix s = map (++s) (map (:[]) ['a'..'z'])- allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]- okayVars = filter (`notElem` vars) allVars- runStateT (crawl rename value) (okayVars, 0, 0, 0)- return value+variableToSrcType :: Variable -> Variable -> IO T.CanonicalType+variableToSrcType rootVariable variable =+ do desc <- UF.descriptor variable+ srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)+ case alias desc of+ Nothing ->+ return srcType++ Just (name, args) ->+ case srcType of+ T.Type (Var.Canonical Var.BuiltIn _) ->+ return srcType++ _ ->+ do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args+ return (T.Aliased name args' (T.Filled srcType)) where- getNames desc state@(vars, a, b, c) =- let name' = name desc in- case name' of- Just (Var.Canonical _ var) -> (name', (var:vars, a, b, c))- _ -> (name', state)+ backupSrcType :: Descriptor -> IO T.CanonicalType+ backupSrcType desc =+ case name desc of+ Just v@(Var.Canonical _ x@(c:_))+ | Char.isLower c ->+ return (T.Var x)+ | otherwise ->+ return $ T.Type v - rename desc state@(vars, a, b, c) =- case name desc of- Just var -> (Just var, state)- Nothing ->- case flex desc of- Is Number -> (local $ "number" ++ replicate a '\'', (vars, a+1, b, c))- Is Comparable -> (local $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))- Is Appendable -> (local $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))- _ -> (local $ head vars, (tail vars, a, b, c))- where- local v = Just (Var.local v)+ _ ->+ error $+ concat+ [ "Problem converting the following type "+ , "from a type-checker type to a source-syntax type:"+ , P.render (pretty Never rootVariable)+ ] --- CRAWLING OVER TYPES+termToSrcType :: Variable -> Term1 Variable -> IO T.CanonicalType+termToSrcType rootVariable term =+ let go = variableToSrcType rootVariable in+ case term of+ App1 a b ->+ do a' <- go a+ b' <- go b+ case a' of+ T.App f args ->+ return $ T.App f (args ++ [b'])+ _ ->+ return $ T.App a' [b'] -type CrawlState = ([String], Int, Int, Int)+ Fun1 a b ->+ T.Lambda <$> go a <*> go b + Var1 a ->+ go a --- Code for traversing all the type data-structures and giving--- names to the variables embedded deep in there.-class Crawl t where- crawl :: (Descriptor -> CrawlState -> (Maybe TypeName, CrawlState))- -> t- -> StateT CrawlState IO t+ EmptyRecord1 ->+ return $ T.Record [] Nothing + Record1 tfields extension ->+ do fields' <- Traverse.traverse (mapM go) tfields+ let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]+ ext' <- dealias <$> go extension+ return $+ case ext' of+ T.Record fs ext -> T.Record (fs ++ fields) ext+ T.Var _ -> T.Record fields (Just ext')+ _ -> error "Used toSrcType on a type that is not well-formed"+ where+ dealias :: T.CanonicalType -> T.CanonicalType+ dealias tipe =+ case tipe of+ T.Aliased _ args tipe' ->+ T.dealias args tipe'+ _ ->+ tipe -instance Crawl e => Crawl (Annotated a e) where- crawl nextState (A ann e) = A ann <$> crawl nextState e +-- ADD NAMES TO TYPES -instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where- crawl nextState constraint = - let rnm = crawl nextState in- case constraint of- CTrue -> return CTrue- CSaveEnv -> return CSaveEnv- CEqual a b -> CEqual <$> rnm a <*> rnm b- CAnd cs -> CAnd <$> crawl nextState cs- CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c - CInstance name tipe -> CInstance name <$> rnm tipe+addNames :: Variable -> IO ()+addNames variable =+ do usedNames <- getVarNames variable+ let freeNames = makeFreeNames usedNames+ State.runStateT (varAddNames variable) (NameState freeNames 0 0 0)+ return () -instance Crawl a => Crawl [a] where- crawl nextState list = mapM (crawl nextState) list+makeFreeNames :: Set.Set String -> [String]+makeFreeNames usedNames =+ let makeName suffix =+ map (:suffix) ['a'..'z'] + allNames =+ concatMap makeName ("" : "'" : "_" : map show [ (0 :: Int) .. ])+ in+ filter (\name -> Set.notMember name usedNames) allNames -instance (Crawl t, Crawl v) => Crawl (Scheme t v) where- crawl nextState (Scheme rqs fqs c headers) =- let rnm = crawl nextState- in- Scheme- <$> rnm rqs- <*> rnm fqs- <*> crawl nextState c- <*> return headers +data NameState = NameState+ { freeNames :: [String]+ , numberPrimes :: Int+ , comparablePrimes :: Int+ , appendablePrimes :: Int+ } -instance Crawl t => Crawl (TermN t) where- crawl nextState tipe =- case tipe of- VarN a x ->- VarN a <$> crawl nextState x - TermN a term ->- TermN a <$> crawl nextState term+varAddNames :: Variable -> StateT NameState IO ()+varAddNames var =+ do desc <- liftIO (UF.descriptor var)+ case alias desc of+ Nothing ->+ return () + Just (_name, args) ->+ mapM_ (\(v,t) -> (,) v <$> varAddNames t) args -instance Crawl t => Crawl (Term1 t) where- crawl nextState term =- let rnm = crawl nextState in- case term of- App1 a b -> App1 <$> rnm a <*> rnm b- Fun1 a b -> Fun1 <$> rnm a <*> rnm b- Var1 a -> Var1 <$> rnm a- EmptyRecord1 -> return EmptyRecord1- Record1 fields ext ->- Record1 <$> traverse (mapM rnm) fields <*> rnm ext+ case structure desc of+ Just term ->+ termAddNames term + Nothing ->+ case name desc of+ Just _ -> return ()+ Nothing ->+ do name' <- createName desc+ liftIO $ UF.modifyDescriptor var $ \desc ->+ desc { name = Just (Var.local name') } -instance Crawl a => Crawl (UF.Point a) where- crawl nextState point =- do desc <- liftIO $ UF.descriptor point- desc' <- crawl nextState desc- liftIO $ UF.setDescriptor point desc'- return point +termAddNames :: Term1 Variable -> StateT NameState IO ()+termAddNames term =+ case term of+ App1 a b ->+ do varAddNames a+ varAddNames b -instance Crawl Descriptor where- crawl nextState desc =- do state <- get- let (name', state') = nextState desc state- structure' <- traverse (crawl nextState) (structure desc)- put state'- return $ desc { name = name', structure = structure' }+ Fun1 a b ->+ do varAddNames a+ varAddNames b - -toSrcType :: Variable -> IO T.CanonicalType-toSrcType var =- go =<< addNames var- where- go v =- do desc <- UF.descriptor v- srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)- return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)+ Var1 a ->+ varAddNames a - backupSrcType desc = - case name desc of- Just v@(Var.Canonical _ x@(c:_))- | Char.isLower c -> return (T.Var x)- | otherwise -> return $ T.Type v+ EmptyRecord1 ->+ return () - _ -> error $ concat- [ "Problem converting the following type "- , "from a type-checker type to a source-syntax type:"- , P.render (pretty Never var) ]+ Record1 fields extension ->+ do mapM_ varAddNames (concat (Map.elems fields))+ varAddNames extension - termToSrcType term =- case term of- App1 a b -> do- a' <- go a- b' <- go b- case a' of- T.App f args -> return $ T.App f (args ++ [b'])- _ -> return $ T.App a' [b'] - Fun1 a b -> T.Lambda <$> go a <*> go b+createName :: (Monad m) => Descriptor -> StateT NameState m String+createName desc =+ case flex desc of+ Is Number ->+ do primes <- State.gets numberPrimes+ State.modify (\state -> state { numberPrimes = primes + 1 })+ return ("number" ++ replicate primes '\'') - Var1 a -> go a+ Is Comparable ->+ do primes <- State.gets comparablePrimes+ State.modify (\state -> state { comparablePrimes = primes + 1 })+ return ("comparable" ++ replicate primes '\'') - EmptyRecord1 -> return $ T.Record [] Nothing+ Is Appendable ->+ do primes <- State.gets appendablePrimes+ State.modify (\state -> state { appendablePrimes = primes + 1 })+ return ("appendable" ++ replicate primes '\'') - Record1 tfields extension -> do- fields' <- traverse (mapM go) tfields- let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]- ext' <- dealias <$> go extension- return $ case ext' of- T.Record fs ext -> T.Record (fs ++ fields) ext- T.Var _ -> T.Record fields (Just ext')- _ -> error "Used toSrcType on a type that is not well-formed"+ _ ->+ do names <- State.gets freeNames+ State.modify (\state -> state { freeNames = tail names })+ return (head names) - dealias :: T.CanonicalType -> T.CanonicalType- dealias t =- case t of- T.Aliased _ t' -> t'- _ -> t +-- GET ALL VARIABLE NAMES -data AppStructure = List Variable | Tuple [Variable] | Other+getVarNames :: Variable -> IO (Set.Set String)+getVarNames var =+ do desc <- UF.descriptor var + let baseSet =+ case name desc of+ Just var -> Set.singleton (Var.toString var)+ Nothing -> Set.empty + structureSet <-+ case structure desc of+ Nothing -> return Set.empty+ Just term -> getVarNamesTerm term++ aliasSet <-+ case alias desc of+ Nothing ->+ return Set.empty++ Just (_name, args) ->+ do let set = Set.fromList (map fst args)+ sets <- mapM (getVarNames . snd) args+ return (Set.unions (set : sets))++ return (Set.unions [ baseSet, structureSet, aliasSet ])+++getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)+getVarNamesTerm term =+ let go = getVarNames in+ case term of+ App1 a b ->+ Set.union <$> go a <*> go b++ Fun1 a b ->+ Set.union <$> go a <*> go b++ Var1 a ->+ go a++ EmptyRecord1 ->+ return Set.empty++ Record1 fields extension ->+ do fieldVars <- Set.unions <$> mapM go (concat (Map.elems fields))+ Set.union fieldVars <$> go extension+++-- COLLECT APPLICATIONS++data AppStructure+ = List Variable+ | Tuple [Variable]+ | Other++ collectApps :: Variable -> IO AppStructure-collectApps var = go [] var+collectApps var =+ go [] var where go vars var = do desc <- UF.descriptor var
src/Type/Unify.hs view
@@ -57,45 +57,50 @@ (name', flex', rank', alias') = combinedDescriptors desc1 desc2 merge1 :: Unify ()- merge1 = liftIO $ do- if rank desc1 < rank desc2 then UF.union variable2 variable1- else UF.union variable1 variable2- UF.modifyDescriptor variable1 $ \desc ->- desc { structure = structure desc1- , flex = flex'- , name = name'- , alias = alias'- }+ merge1 =+ liftIO $ do+ if rank desc1 < rank desc2+ then UF.union variable2 variable1+ else UF.union variable1 variable2+ UF.modifyDescriptor variable1 $ \desc ->+ desc { structure = structure desc1+ , flex = flex'+ , name = name'+ , alias = alias'+ } merge2 :: Unify ()- merge2 = liftIO $ do- if rank desc1 < rank desc2 then UF.union variable2 variable1- else UF.union variable1 variable2- UF.modifyDescriptor variable2 $ \desc ->- desc { structure = structure desc2+ merge2 =+ liftIO $ do+ if rank desc1 < rank desc2+ then UF.union variable2 variable1+ else UF.union variable1 variable2+ UF.modifyDescriptor variable2 $ \desc ->+ desc { structure = structure desc2+ , flex = flex'+ , name = name'+ , alias = alias'+ }++ merge =+ if rank desc1 < rank desc2 then merge1 else merge2++ fresh :: Maybe (Term1 Variable) -> Unify Variable+ fresh structure =+ do v <- liftIO . UF.fresh $ Descriptor+ { structure = structure+ , rank = rank' , flex = flex' , name = name'+ , copy = Nothing+ , mark = noMark , alias = alias' }-- merge = if rank desc1 < rank desc2 then merge1 else merge2-- fresh :: Maybe (Term1 Variable) -> Unify Variable- fresh structure = do- v <- liftIO . UF.fresh $ Descriptor- { structure = structure- , rank = rank'- , flex = flex'- , name = name'- , copy = Nothing- , mark = noMark- , alias = alias'- }- lift (TS.register v)+ lift (TS.register v) - flexAndUnify v = do- liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }- unifyHelp' variable1 variable2+ flexAndUnify v =+ do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }+ unifyHelp' variable1 variable2 unifyNumber svar (Var.Canonical home name) = case home of@@ -127,24 +132,28 @@ _ -> comparableError Nothing unifyComparableStructure varSuper varFlex =- do struct <- liftIO $ collectApps varFlex- case struct of- Other -> comparableError Nothing- List v -> do flexAndUnify varSuper- unifyHelp' v =<< liftIO (variable $ Is Comparable)- Tuple vs- | length vs > 6 ->- comparableError $ Just "Cannot compare a tuple with more than 6 elements."- | otherwise -> - do flexAndUnify varSuper+ do struct <- liftIO $ collectApps varFlex+ case struct of+ Other ->+ comparableError Nothing++ List v ->+ do flexAndUnify varSuper+ unifyHelp' v =<< liftIO (variable $ Is Comparable)++ Tuple vs+ | length vs > 6 ->+ comparableError $ Just "Cannot compare a tuple with more than 6 elements."+ | otherwise ->+ do flexAndUnify varSuper cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable) zipWithM_ unifyHelp' vs cmpVars unifyAppendable varSuper varFlex =- do struct <- liftIO $ collectApps varFlex- case struct of- List _ -> flexAndUnify varSuper- _ -> appendableError Nothing+ do struct <- liftIO $ collectApps varFlex+ case struct of+ List _ -> flexAndUnify varSuper+ _ -> appendableError Nothing rigidError var = typeError region (Just hint) variable1 variable2@@ -160,7 +169,7 @@ | super1 == super2 -> merge (Is Number, Is Comparable, _, _) -> merge1 (Is Comparable, Is Number, _, _) -> merge2- + (Is Number, _, _, Just name) -> unifyNumber variable1 name (_, Is Number, Just name, _) -> unifyNumber variable2 name @@ -181,16 +190,27 @@ _ -> typeError region Nothing variable1 variable2 case (structure desc1, structure desc2) of- (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge- (Nothing, _) | flex desc1 == Flexible -> merge2- (_, Nothing) | flex desc2 == Flexible -> merge1+ (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->+ merge - (Just (Var1 v), _) -> unifyHelp' v variable2- (_, Just (Var1 v)) -> unifyHelp' v variable1+ (Nothing, _) | flex desc1 == Flexible ->+ merge2 - (Nothing, _) -> superUnify- (_, Nothing) -> superUnify+ (_, Nothing) | flex desc2 == Flexible ->+ merge1 + (Just (Var1 v), _) ->+ unifyHelp' v variable2++ (_, Just (Var1 v)) ->+ unifyHelp' variable1 v++ (Nothing, _) ->+ superUnify++ (_, Nothing) ->+ superUnify+ (Just type1, Just type2) -> case (type1,type2) of (App1 term1 term2, App1 term1' term2') ->@@ -206,7 +226,7 @@ return () (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2- (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' ext variable1+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' variable1 ext (Record1 _ _, Record1 _ _) -> recordUnify region fresh variable1 variable2@@ -288,7 +308,7 @@ -> Unify () unifyOverlappingFields region fields1 fields2 = Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2- |> Map.elems + |> Map.elems |> concat |> sequence_ @@ -338,36 +358,42 @@ ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys -combinedDescriptors :: Descriptor -> Descriptor- -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)+combinedDescriptors+ :: Descriptor+ -> Descriptor+ -> (Maybe Var.Canonical, Flex, Int, Alias Variable) combinedDescriptors desc1 desc2 = (name', flex', rank', alias') where rank' :: Int- rank' = min (rank desc1) (rank desc2)+ rank' =+ min (rank desc1) (rank desc2) - alias' :: Maybe Var.Canonical- alias' = alias desc1 <|> alias desc2+ alias' :: Alias Variable+ alias' =+ alias desc1 <|> alias desc2 name' :: Maybe Var.Canonical- name' = case (name desc1, name desc2) of- (Just name1, Just name2) ->- case (flex desc1, flex desc2) of- (_, Flexible) -> Just name1- (Flexible, _) -> Just name2- (Is Number, Is _) -> Just name1- (Is _, Is Number) -> Just name2- (Is _, Is _) -> Just name1- (_, _) -> Nothing- (Just name1, _) -> Just name1- (_, Just name2) -> Just name2- _ -> Nothing+ name' =+ case (name desc1, name desc2) of+ (Just name1, Just name2) ->+ case (flex desc1, flex desc2) of+ (_, Flexible) -> Just name1+ (Flexible, _) -> Just name2+ (Is Number, Is _) -> Just name1+ (Is _, Is Number) -> Just name2+ (Is _, Is _) -> Just name1+ (_, _) -> Nothing+ (Just name1, _) -> Just name1+ (_, Just name2) -> Just name2+ _ -> Nothing flex' :: Flex- flex' = case (flex desc1, flex desc2) of- (f, Flexible) -> f- (Flexible, f) -> f- (Is Number, Is _) -> Is Number- (Is _, Is Number) -> Is Number- (Is super, Is _) -> Is super- (_, _) -> Flexible+ flex' =+ case (flex desc1, flex desc2) of+ (f, Flexible) -> f+ (Flexible, f) -> f+ (Is Number, Is _) -> Is Number+ (Is _, Is Number) -> Is Number+ (Is super, Is _) -> Is super+ (_, _) -> Flexible
tests/Test/Compiler.hs view
@@ -39,7 +39,7 @@ testsDir :: FilePath testsDir =- "tests" </> "compiler" </> "test-files"+ "tests" </> "test-files" -- RUN COMPILER@@ -69,5 +69,5 @@ isFailure :: Either a b -> Assertion isFailure result = case result of- Left _ -> assertFailure "Compilation succeeded but should have failed"- Right _ -> assertBool "" True+ Right _ -> assertFailure "Compilation succeeded but should have failed"+ Left _ -> assertBool "" True
tests/Test/Property/Arbitrary.hs view
@@ -13,71 +13,104 @@ import qualified AST.Type as T import qualified AST.Variable as V + instance Arbitrary V.Raw where- arbitrary = V.Raw <$> capVar- shrink (V.Raw v) = V.Raw <$> shrink v+ arbitrary =+ V.Raw <$> capVar + shrink (V.Raw v) =+ V.Raw <$> shrink v++ instance Arbitrary L.Literal where arbitrary = oneof- [ L.IntNum <$> arbitrary- , L.FloatNum <$> (arbitrary `suchThat` noE)- , L.Chr <$> arbitrary- -- This is too permissive- , L.Str <$> arbitrary- -- Booleans aren't actually source syntax - -- , Boolean <$> arbitrary- ]+ [ L.IntNum <$> arbitrary+ , L.FloatNum <$> (arbitrary `suchThat` noE)+ , L.Chr <$> arbitrary+ -- This is too permissive+ , L.Str <$> arbitrary+ -- Booleans aren't actually source syntax+ -- , Boolean <$> arbitrary+ ] - shrink lit =- case lit of- L.IntNum n -> L.IntNum <$> shrink n- L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)- L.Chr c -> L.Chr <$> shrink c- L.Str s -> L.Str <$> shrink s- L.Boolean b -> L.Boolean <$> shrink b+ shrink literal =+ case literal of+ L.IntNum int ->+ L.IntNum <$> shrink int + L.FloatNum float ->+ L.FloatNum <$> filter noE (shrink float)++ L.Chr char ->+ L.Chr <$> shrink char++ L.Str string ->+ L.Str <$> shrink string++ L.Boolean bool ->+ L.Boolean <$> shrink bool++ noE :: Double -> Bool-noE = notElem 'e' . show+noE =+ notElem 'e' . show + genVector :: Int -> (Int -> Gen a) -> Gen [a]-genVector n generator = do- len <- choose (0,n)- let m = n `div` (len + 1)- vectorOf len $ generator m+genVector n generator =+ do len <- choose (0,n)+ let m = n `div` (len + 1)+ vectorOf len $ generator m instance Arbitrary v => Arbitrary (P.Pattern v) where- arbitrary = sized pat+ arbitrary =+ sized pattern where- pat :: (Arbitrary v) => Int -> Gen (P.Pattern v)- pat n =+ pattern :: (Arbitrary v) => Int -> Gen (P.Pattern v)+ pattern n = oneof [ pure P.Anything , P.Var <$> lowVar , P.Record <$> (listOf1 lowVar) , P.Literal <$> arbitrary- , P.Alias <$> lowVar <*> pat (n-1)- , P.Data <$> arbitrary <*> genVector n pat+ , P.Alias <$> lowVar <*> pattern (n-1)+ , P.Data <$> arbitrary <*> genVector n pattern ] - shrink pat =- case pat of- P.Anything -> []- P.Var v -> P.Var <$> shrinkWHead v- P.Literal l -> P.Literal <$> shrink l- P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)- P.Data s ps -> ps ++ (P.Data <$> shrink s <*> shrink ps)- P.Record fs ->- P.Record <$> filter (all notNull) (filter notNull (shrink fs))- where- notNull = not . null+ shrink pattern =+ case pattern of+ P.Anything ->+ [] -shrinkWHead :: Arbitrary a => [a] -> [[a]]-shrinkWHead [] = error "Should be nonempty"-shrinkWHead (x:xs) = (x:) <$> shrink xs+ P.Var var ->+ P.Var <$> consAndShrink var + P.Literal literal ->+ P.Literal <$> shrink literal++ P.Alias alias pattern ->+ pattern : (P.Alias <$> consAndShrink alias <*> shrink pattern)++ P.Data name patterns ->+ patterns ++ (P.Data <$> shrink name <*> shrink patterns)++ P.Record fields ->+ P.Record <$> filter (all notNull) (filter notNull (shrink fields))+ where+ notNull = not . null+++consAndShrink :: Arbitrary a => [a] -> [[a]]+consAndShrink values =+ case values of+ [] -> error "Should be nonempty"+ x:xs -> (x:) <$> shrink xs++ instance Arbitrary v => Arbitrary (T.Type v) where- arbitrary = sized tipe+ arbitrary =+ sized tipe where tipe :: Arbitrary v => Int -> Gen (T.Type v) tipe n =@@ -88,50 +121,72 @@ depthTipes = (:) <$> depthTipe <*> genVector n tipe in oneof- [ T.Lambda <$> depthTipe <*> depthTipe- , T.Var <$> lowVar- , T.Type <$> arbitrary- , T.App <$> (T.Type <$> arbitrary) <*> depthTipes- , T.Record <$> fields <*> pure Nothing- , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)- ]+ [ T.Lambda <$> depthTipe <*> depthTipe+ , T.Var <$> lowVar+ , T.Type <$> arbitrary+ , T.App <$> (T.Type <$> arbitrary) <*> depthTipes+ , T.Record <$> fields <*> pure Nothing+ , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)+ ] shrink tipe = case tipe of- T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)- T.Var _ -> []- T.Aliased v t -> t : (T.Aliased v <$> shrink t)- T.Type v -> T.Type <$> shrink v- T.App t ts -> t : ts ++ (T.App <$> shrink t <*> shrink ts)- T.Record fs t -> map snd fs ++ record- where- record =- case t of- Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing- Just _ ->- do fields <- filter (not . null) $ shrinkList shrinkField fs- return $ T.Record fields t+ T.Lambda arg result ->+ arg : result : (T.Lambda <$> shrink arg <*> shrink result) - shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t+ T.Var _ ->+ [] + T.Aliased name tvars rootType ->+ rootType : (T.Aliased name <$> shrinkList shrinkPair tvars <*> shrink rootType)++ T.Type name ->+ T.Type <$> shrink name++ T.App func args ->+ func : args ++ (T.App <$> shrink func <*> shrink args)++ T.Record fields extension ->+ map snd fields ++ record+ where+ record =+ case extension of+ Nothing ->+ T.Record <$> shrinkList shrinkPair fields <*> pure Nothing++ Just _ ->+ do fields' <- filter (not . null) $ shrinkList shrinkPair fields+ return $ T.Record fields' extension+ where+ shrinkPair (name, tipe) =+ (,) <$> consAndShrink name <*> shrink tipe++ lowVar :: Gen String-lowVar = notReserved $ (:) <$> lower <*> listOf varLetter- where- lower = elements ['a'..'z']+lowVar =+ notReserved $+ (:) <$> elements ['a'..'z'] <*> listOf varLetter + capVar :: Gen String-capVar = notReserved $ (:) <$> upper <*> listOf varLetter- where- upper = elements ['A'..'Z']+capVar =+ notReserved $+ (:) <$> elements ['A'..'Z'] <*> listOf varLetter + varLetter :: Gen Char-varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']+varLetter =+ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_'] + notReserved :: Gen String -> Gen String-notReserved = flip exceptFor Parse.Helpers.reserveds+notReserved string =+ string `exceptFor` Parse.Helpers.reserveds + exceptFor :: (Ord a) => Gen a -> [a] -> Gen a-exceptFor g xs = g `suchThat` notAnX+exceptFor generator list =+ generator `suchThat` notInList where- notAnX = flip Set.notMember xset- xset = Set.fromList xs+ set = Set.fromList list+ notInList x = Set.notMember x set