diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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: diff --git a/elm-compiler.cabal b/elm-compiler.cabal --- a/elm-compiler.cabal +++ b/elm-compiler.cabal @@ -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, diff --git a/src/AST/Declaration.hs b/src/AST/Declaration.hs --- a/src/AST/Declaration.hs +++ b/src/AST/Declaration.hs @@ -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) diff --git a/src/AST/Expression/Canonical.hs b/src/AST/Expression/Canonical.hs --- a/src/AST/Expression/Canonical.hs +++ b/src/AST/Expression/Canonical.hs @@ -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 diff --git a/src/AST/Expression/General.hs b/src/AST/Expression/General.hs --- a/src/AST/Expression/General.hs +++ b/src/AST/Expression/General.hs @@ -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 portImpl -> + pretty portImpl - PortOut _ _ signal -> pretty signal + +instance (Pretty expr, Pretty var) => Pretty (PortImpl expr var) where + pretty impl = + P.text ("") collectApps :: Expr ann def var -> [Expr ann def var] diff --git a/src/AST/Expression/Source.hs b/src/AST/Expression/Source.hs --- a/src/AST/Expression/Source.hs +++ b/src/AST/Expression/Source.hs @@ -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 diff --git a/src/AST/Expression/Valid.hs b/src/AST/Expression/Valid.hs --- a/src/AST/Expression/Valid.hs +++ b/src/AST/Expression/Valid.hs @@ -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 diff --git a/src/AST/Helpers.hs b/src/AST/Helpers.hs --- a/src/AST/Helpers.hs +++ b/src/AST/Helpers.hs @@ -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 "+-/*=.$<>:&|^?%#@~!" diff --git a/src/AST/Module.hs b/src/AST/Module.hs --- a/src/AST/Module.hs +++ b/src/AST/Module.hs @@ -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 diff --git a/src/AST/Pattern.hs b/src/AST/Pattern.hs --- a/src/AST/Pattern.hs +++ b/src/AST/Pattern.hs @@ -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 = diff --git a/src/AST/PrettyPrint.hs b/src/AST/PrettyPrint.hs --- a/src/AST/PrettyPrint.hs +++ b/src/AST/PrettyPrint.hs @@ -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 ] diff --git a/src/AST/Type.hs b/src/AST/Type.hs --- a/src/AST/Type.hs +++ b/src/AST/Type.hs @@ -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" diff --git a/src/AST/Variable.hs b/src/AST/Variable.hs --- a/src/AST/Variable.hs +++ b/src/AST/Variable.hs @@ -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 diff --git a/src/CommandLineRouter.hs b/src/CommandLineRouter.hs new file mode 100644 --- /dev/null +++ b/src/CommandLineRouter.hs @@ -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 []\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 --help\n\ + \\n\ + \In all these cases we are simply running 'elm-' 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 \n\ + \ reactor Develop with compile-on-refresh and time-travel debugging\n\ + \ repl A REPL for running individual expressions\n" + diff --git a/src/Docs.hs b/src/Docs.hs --- a/src/Docs.hs +++ b/src/Docs.hs @@ -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 " +errorMessage :: String -> String +errorMessage name = + "Unable to deal with annotations on " ++ name ++ " at this time.\n" ++ + "Please report your use case to " -- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS diff --git a/src/Elm/Compiler.hs b/src/Elm/Compiler.hs --- a/src/Elm/Compiler.hs +++ b/src/Elm/Compiler.hs @@ -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 diff --git a/src/Elm/Compiler/Module.hs b/src/Elm/Compiler/Module.hs --- a/src/Elm/Compiler/Module.hs +++ b/src/Elm/Compiler/Module.hs @@ -34,7 +34,7 @@ defaultImports :: [Name] defaultImports = - map Name (Map.keys Defaults.defaultImports) + map (Name . fst) Defaults.defaultImports -- POKING AROUND INTERFACES diff --git a/src/Elm/Compiler/Type.hs b/src/Elm/Compiler/Type.hs --- a/src/Elm/Compiler/Type.hs +++ b/src/Elm/Compiler/Type.hs @@ -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 " + 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 diff --git a/src/Elm/Compiler/Type/Extract.hs b/src/Elm/Compiler/Type/Extract.hs --- a/src/Elm/Compiler/Type/Extract.hs +++ b/src/Elm/Compiler/Type/Extract.hs @@ -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) diff --git a/src/Elm/Compiler/Version.hs b/src/Elm/Compiler/Version.hs --- a/src/Elm/Compiler/Version.hs +++ b/src/Elm/Compiler/Version.hs @@ -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 diff --git a/src/Elm/Utils.hs b/src/Elm/Utils.hs --- a/src/Elm/Utils.hs +++ b/src/Elm/Utils.hs @@ -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 diff --git a/src/Generate/JavaScript.hs b/src/Generate/JavaScript.hs --- a/src/Generate/JavaScript.hs +++ b/src/Generate/JavaScript.hs @@ -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 ] diff --git a/src/Generate/JavaScript/Port.hs b/src/Generate/JavaScript/Port.hs new file mode 100644 --- /dev/null +++ b/src/Generate/JavaScript/Port.hs @@ -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))) diff --git a/src/Generate/JavaScript/Ports.hs b/src/Generate/JavaScript/Ports.hs deleted file mode 100644 --- a/src/Generate/JavaScript/Ports.hs +++ /dev/null @@ -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))) diff --git a/src/Parse/Declaration.hs b/src/Parse/Declaration.hs --- a/src/Parse/Declaration.hs +++ b/src/Parse/Declaration.hs @@ -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)) + diff --git a/src/Parse/Expression.hs b/src/Parse/Expression.hs --- a/src/Parse/Expression.hs +++ b/src/Parse/Expression.hs @@ -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 ] diff --git a/src/Parse/Helpers.hs b/src/Parse/Helpers.hs --- a/src/Parse/Helpers.hs +++ b/src/Parse/Helpers.hs @@ -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) diff --git a/src/Parse/Module.hs b/src/Parse/Module.hs --- a/src/Parse/Module.hs +++ b/src/Parse/Module.hs @@ -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) diff --git a/src/Transform/AddDefaultImports.hs b/src/Transform/AddDefaultImports.hs --- a/src/Transform/AddDefaultImports.hs +++ b/src/Transform/AddDefaultImports.hs @@ -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 diff --git a/src/Transform/Canonicalize.hs b/src/Transform/Canonicalize.hs --- a/src/Transform/Canonicalize.hs +++ b/src/Transform/Canonicalize.hs @@ -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 diff --git a/src/Transform/Canonicalize/Environment.hs b/src/Transform/Canonicalize/Environment.hs --- a/src/Transform/Canonicalize/Environment.hs +++ b/src/Transform/Canonicalize/Environment.hs @@ -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 diff --git a/src/Transform/Canonicalize/Port.hs b/src/Transform/Canonicalize/Port.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Canonicalize/Port.hs @@ -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 diff --git a/src/Transform/Canonicalize/Setup.hs b/src/Transform/Canonicalize/Setup.hs --- a/src/Transform/Canonicalize/Setup.hs +++ b/src/Transform/Canonicalize/Setup.hs @@ -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 diff --git a/src/Transform/Canonicalize/Type.hs b/src/Transform/Canonicalize/Type.hs --- a/src/Transform/Canonicalize/Type.hs +++ b/src/Transform/Canonicalize/Type.hs @@ -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 diff --git a/src/Transform/Canonicalize/Variable.hs b/src/Transform/Canonicalize/Variable.hs --- a/src/Transform/Canonicalize/Variable.hs +++ b/src/Transform/Canonicalize/Variable.hs @@ -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" diff --git a/src/Transform/Check.hs b/src/Transform/Check.hs --- a/src/Transform/Check.hs +++ b/src/Transform/Check.hs @@ -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:" diff --git a/src/Transform/Declaration.hs b/src/Transform/Declaration.hs --- a/src/Transform/Declaration.hs +++ b/src/Transform/Declaration.hs @@ -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) diff --git a/src/Transform/Definition.hs b/src/Transform/Definition.hs --- a/src/Transform/Definition.hs +++ b/src/Transform/Definition.hs @@ -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 [] diff --git a/src/Transform/Expression.hs b/src/Transform/Expression.hs --- a/src/Transform/Expression.hs +++ b/src/Transform/Expression.hs @@ -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) diff --git a/src/Transform/SortDefinitions.hs b/src/Transform/SortDefinitions.hs --- a/src/Transform/SortDefinitions.hs +++ b/src/Transform/SortDefinitions.hs @@ -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) diff --git a/src/Transform/Substitute.hs b/src/Transform/Substitute.hs --- a/src/Transform/Substitute.hs +++ b/src/Transform/Substitute.hs @@ -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 diff --git a/src/Type/Constrain/Expression.hs b/src/Type/Constrain/Expression.hs --- a/src/Type/Constrain/Expression.hs +++ b/src/Type/Constrain/Expression.hs @@ -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 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 t2 ==> tipe) ] + exists $ \t2 -> + do c1 <- constrain env e1 t1 + c2 <- constrain env e2 t2 + return $ and [ c1, c2, V.toString op 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 liftIO (variable Flexible) + let pairs = zip exprs (map varN vars) + (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs) + return $ ex vars (cs /\ name 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 + } diff --git a/src/Type/Environment.hs b/src/Type/Environment.hs --- a/src/Type/Environment.hs +++ b/src/Type/Environment.hs @@ -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') diff --git a/src/Type/ExtraChecks.hs b/src/Type/ExtraChecks.hs --- a/src/Type/ExtraChecks.hs +++ b/src/Type/ExtraChecks.hs @@ -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)) diff --git a/src/Type/Inference.hs b/src/Type/Inference.hs --- a/src/Type/Inference.hs +++ b/src/Type/Inference.hs @@ -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 diff --git a/src/Type/State.hs b/src/Type/State.hs --- a/src/Type/State.hs +++ b/src/Type/State.hs @@ -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 diff --git a/src/Type/Type.hs b/src/Type/Type.hs --- a/src/Type/Type.hs +++ b/src/Type/Type.hs @@ -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 diff --git a/src/Type/Unify.hs b/src/Type/Unify.hs --- a/src/Type/Unify.hs +++ b/src/Type/Unify.hs @@ -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 diff --git a/tests/Test/Compiler.hs b/tests/Test/Compiler.hs --- a/tests/Test/Compiler.hs +++ b/tests/Test/Compiler.hs @@ -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 diff --git a/tests/Test/Property/Arbitrary.hs b/tests/Test/Property/Arbitrary.hs --- a/tests/Test/Property/Arbitrary.hs +++ b/tests/Test/Property/Arbitrary.hs @@ -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