From 82f888cb3df56b48839a55af1af27beab8aec3bd Mon Sep 17 00:00:00 2001 From: evancz Date: Thu, 4 Apr 2013 01:09:35 -0700 Subject: [PATCH] Get the type-checker running based on docs.json information. Also add rules for `Nil` and `Tuple0`, `Tuple2`, etc. --- compiler/Compiler.hs | 9 ++------- compiler/Gen/CompileToJS.hs | 1 - compiler/Model/Ast.hs | 7 ++++--- compiler/Model/Libraries.hs | 19 ++++++++++++++++-- compiler/Parse/Library.hs | 2 -- compiler/Types/Constrain.hs | 40 ++++++++++++++++++------------------- compiler/Types/Types.hs | 9 +-------- 7 files changed, 44 insertions(+), 43 deletions(-) diff --git a/compiler/Compiler.hs b/compiler/Compiler.hs index 74e70a5..6bf7ef7 100644 --- a/compiler/Compiler.hs +++ b/compiler/Compiler.hs @@ -17,6 +17,7 @@ import Ast import Initialize import CompileToJS import GenerateHtml +import qualified Libraries as Libraries import Paths_Elm data ELM = @@ -89,14 +90,8 @@ fileTo flags what rtLoc file = do writeFile js (formatJS txt) addPrelude (Module name exs ims stmts) = Module name exs (prelude ++ ims) stmts - where prelude = concatMap addModule allModules + where prelude = concatMap addModule Libraries.prelude addModule (n, method) = case lookup n ims of Nothing -> [(n, method)] Just _ -> [] - modules = [ "Prelude", "Signal", "List", "Maybe" - , "Time", "Graphics.Element", "Graphics.Color" ] - - text = ("Graphics.Text", Hiding ["link", "color"]) - - allModules = text : map (\n -> (n, Hiding [])) modules \ No newline at end of file diff --git a/compiler/Gen/CompileToJS.hs b/compiler/Gen/CompileToJS.hs index c188d8e..43329c4 100644 --- a/compiler/Gen/CompileToJS.hs +++ b/compiler/Gen/CompileToJS.hs @@ -14,7 +14,6 @@ import Rename (derename) import Cases import Guid import LetBoundVars -import Parse.Library (isOp) import Rename (deprime) import Types.Types ( Type(RecordT) ) diff --git a/compiler/Model/Ast.hs b/compiler/Model/Ast.hs index d2ea43b..eb87fb3 100644 --- a/compiler/Model/Ast.hs +++ b/compiler/Model/Ast.hs @@ -2,7 +2,7 @@ module Ast where import Context -import Data.Char (isDigit) +import Data.Char (isDigit, isSymbol) import Data.List (intercalate) import Types.Types import qualified Text.Pandoc as Pandoc @@ -13,7 +13,7 @@ type Exports = [String] type Imports = [(String, ImportMethod)] data ImportMethod = As String | Importing [String] | Hiding [String] - deriving (Eq,Ord) + deriving (Eq, Ord, Show) data Pattern = PData String [Pattern] @@ -74,6 +74,7 @@ ptuple es = PData ("Tuple" ++ show (length es)) es brkt s = "{ " ++ s ++ " }" parensIf b s = if b then parens s else s +isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!" instance Show Pattern where show p = @@ -118,7 +119,7 @@ instance Show Expr where where iff (b,e) = show b ++ " -> " ++ show e sep = concatMap ("\n | " ++) Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e - Var x -> x + Var (c:cs) -> if isOp c then parens (c:cs) else c:cs Case e pats -> "case "++ show e ++" of " ++ brkt (intercalate " ; " pats') where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats Data name es diff --git a/compiler/Model/Libraries.hs b/compiler/Model/Libraries.hs index cedc92b..a112d30 100644 --- a/compiler/Model/Libraries.hs +++ b/compiler/Model/Libraries.hs @@ -1,13 +1,28 @@ -module Libraries (libraries) where +module Libraries (libraries, prelude) where +import Ast import qualified Data.Map as Map +import Data.List (inits) import Text.JSON import LoadLibraries (docs) +prelude = text : map (\n -> (n, Hiding [])) modules + where + text = ("Graphics.Text", Hiding ["link", "color"]) + modules = [ "Prelude", "Signal", "List", "Maybe", "Time" + , "Graphics.Element", "Graphics.Color" + , "Graphics.Collage", "Graphics.Geometry" ] + libraries :: Map.Map String (Map.Map String String) libraries = case getLibs of - Ok libs -> libs Error err -> error err + Ok libs -> Map.unionWith Map.union libs nilAndTuples + where nilAndTuples = Map.singleton "Prelude" (Map.fromList pairs) + pairs = ("Nil", "List a") : map makeTuple (inits ['a'..'i']) + makeTuple cs = + let name = "Tuple" ++ show (length cs) + in (name, concatMap (\c -> c : " -> ") cs ++ + name ++ concatMap (\c -> [' ',c]) cs) getLibs :: Result (Map.Map String (Map.Map String String)) getLibs = do diff --git a/compiler/Parse/Library.hs b/compiler/Parse/Library.hs index c9483d3..fe5c2eb 100644 --- a/compiler/Parse/Library.hs +++ b/compiler/Parse/Library.hs @@ -58,8 +58,6 @@ reserved word = anyOp :: IParser String anyOp = betwixt '`' '`' var <|> symOp "infix operator (e.g. +, *, ||)" -isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!" - symOp :: IParser String symOp = do op <- many1 (satisfy isOp) guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ]) diff --git a/compiler/Types/Constrain.hs b/compiler/Types/Constrain.hs index a4ebb6e..dc4a77b 100644 --- a/compiler/Types/Constrain.hs +++ b/compiler/Types/Constrain.hs @@ -4,6 +4,7 @@ module Types.Constrain (constrain) where import Control.Arrow (second) import Control.Monad (liftM,mapM,zipWithM,foldM) import Control.Monad.State (evalState) +import Data.Char (isDigit) import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf) import qualified Data.Map as Map import qualified Data.Set as Set @@ -11,6 +12,7 @@ import qualified Data.Set as Set import Ast import Context import Guid +import qualified Libraries as Libraries import Types.Types import Types.Substitutions @@ -19,25 +21,25 @@ beta = VarT `liftM` guid unionA = Map.unionWith (++) unionsA = Map.unionsWith (++) -getAliases imports hints = hints ++ concatMap aliasesFrom imports' - where imports' = map head . group $ sort imports - aliasesFrom (name,method) = - case method of - As alias -> concatMap (findAlias name alias) hints - _ -> [] - findAlias mName' mAlias (name,tipe) = - let mName = mName' ++ "." in - case mName `isPrefixOf` name of - True -> [ (mAlias ++ drop (length mName) name, tipe) ] - False -> [] +getAliases imports hints = hints ++ concatMap aliasesFrom imports + where aliasesFrom (name,method) = + let values = concatMap (getValue name) hints + in case method of + As alias -> map (\(n,t) -> (alias ++ "." ++ n, t)) values + Hiding vs -> filter (\(n,t) -> n `notElem` vs) values + Importing vs -> filter (\(n,t) -> n `elem` vs) values + getValue inModule (name,tipe) = + case inModule `isPrefixOf` name of + True -> [ (drop (length inModule + 1) name, tipe) ] + False -> [] findAmbiguous hints hints' assumptions continue = - let potentialDups = map head . filter (\g -> length g > 1) . group $ sort hints' - dups = filter (\k -> Map.member k assumptions) potentialDups - in case dups of - n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++ "' could refer to " ++ - intercalate ", " (filter (isSuffixOf n) hints) - _ -> continue + let potentialDups = map head . filter (\g -> length g > 1) . group $ sort hints' + dups = filter (\k -> Map.member k assumptions) potentialDups + in case dups of + n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++ + "' could refer to " ++ intercalate ", " (filter (isSuffixOf n) hints) + _ -> continue mergeSchemes :: [Map.Map String Scheme] -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme) @@ -62,9 +64,7 @@ constrain typeHints (Module _ _ imports stmts) = do (as', cs', schemes) <- mergeSchemes schemess let constraints = Set.unions (cs':css) as = unionsA (as':ass) - extraImports = ("Time", Importing []) : map (\n -> (n, Importing [])) - ["List","Signal","Text","Graphics","Color"] - aliasHints = getAliases (imports ++ extraImports) hints + aliasHints = getAliases (imports ++ Libraries.prelude) hints allHints = Map.union schemes (Map.fromList aliasHints) insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as assumptions <- foldM insert as (Map.keys schemes) diff --git a/compiler/Types/Types.hs b/compiler/Types/Types.hs index 9aab56b..2fb9da6 100644 --- a/compiler/Types/Types.hs +++ b/compiler/Types/Types.hs @@ -17,7 +17,7 @@ data Type = LambdaT Type Type | Super (Set.Set Type) deriving (Eq, Ord) -data Scheme = Forall [X] [Context Constraint] Type deriving (Eq, Ord) +data Scheme = Forall [X] [Context Constraint] Type deriving (Eq, Ord, Show) data Constraint = Type :=: Type | Type :<: Type @@ -110,11 +110,4 @@ instance Show Type where _ -> "{ " ++ show t ++ " | " -instance Show Scheme where - show (Forall [] [] t) = show t - show (Forall xs cs t) = - concat [ "Forall ", show xs - , concatMap (("\n "++) . show) cs - , "\n ", parens (show t) ] - isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str) \ No newline at end of file