diff options
| author | PhilFreeman <> | 2014-02-25 00:27:00 (GMT) |
|---|---|---|
| committer | hdiff <hdiff@hdiff.luite.com> | 2014-02-25 00:27:00 (GMT) |
| commit | 4f0ee1881db1a659a4030d6a35487bd9c6d01379 (patch) | |
| tree | 4959422111ff0253c9cdc8d852542b85329869ab | |
| parent | 412228ecc467e2195eaa03bdac3fadb64e0b9cbe (diff) | |
version 0.4.2.10.4.2.1
38 files changed, 816 insertions, 552 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs index ed8d46e..bf817b5 100644 --- a/docgen/Main.hs +++ b/docgen/Main.hs @@ -60,7 +60,7 @@ renderModules ms = do renderModule :: P.Module -> Docs renderModule (P.Module moduleName ds) = do - headerLevel 2 $ "Module " ++ (P.runModuleName moduleName) + headerLevel 2 $ "Module " ++ P.runModuleName moduleName spacer headerLevel 3 "Types" spacer @@ -90,23 +90,23 @@ renderDeclaration n (P.TypeDeclaration ident ty) = renderDeclaration n (P.ExternDeclaration _ ident _ ty) = atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty renderDeclaration n (P.DataDeclaration name args ctors) = do - let typeName = P.runProperName name ++ " " ++ intercalate " " args + let typeName = P.runProperName name ++ " " ++ unwords args atIndent n $ "data " ++ typeName ++ " where" - forM_ ctors $ \(ctor, tys) -> do - atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concat (map (\ty -> P.prettyPrintType ty ++ " -> ") tys) ++ typeName + forM_ ctors $ \(ctor, tys) -> + atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> P.prettyPrintType ty ++ " -> ") tys ++ typeName renderDeclaration n (P.ExternDataDeclaration name kind) = atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do - let typeName = P.runProperName name ++ " " ++ intercalate " " args + let typeName = P.runProperName name ++ " " ++ unwords args atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty -renderDeclaration n (P.TypeClassDeclaration name arg ds) = do - atIndent n $ "class " ++ P.runProperName name ++ " " ++ arg ++ " where" +renderDeclaration n (P.TypeClassDeclaration name args ds) = do + atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where" mapM_ (renderDeclaration (n + 2)) ds -renderDeclaration n (P.TypeInstanceDeclaration constraints name ty _) = do +renderDeclaration n (P.TypeInstanceDeclaration constraints name tys _) = do let constraintsText = case constraints of [] -> "" - cs -> "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ P.prettyPrintType ty' ++ ")") cs) ++ ") => " - atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ P.prettyPrintType ty + cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => " + atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys) renderDeclaration _ _ = return () getName :: P.Declaration -> String @@ -120,22 +120,22 @@ getName (P.TypeInstanceDeclaration _ name _ _) = show name getName _ = error "Invalid argument to getName" isValueDeclaration :: P.Declaration -> Bool -isValueDeclaration (P.TypeDeclaration _ _) = True -isValueDeclaration (P.ExternDeclaration _ _ _ _) = True +isValueDeclaration P.TypeDeclaration{} = True +isValueDeclaration P.ExternDeclaration{} = True isValueDeclaration _ = False isTypeDeclaration :: P.Declaration -> Bool -isTypeDeclaration (P.DataDeclaration _ _ _) = True -isTypeDeclaration (P.ExternDataDeclaration _ _) = True -isTypeDeclaration (P.TypeSynonymDeclaration _ _ _) = True +isTypeDeclaration P.DataDeclaration{} = True +isTypeDeclaration P.ExternDataDeclaration{} = True +isTypeDeclaration P.TypeSynonymDeclaration{} = True isTypeDeclaration _ = False isTypeClassDeclaration :: P.Declaration -> Bool -isTypeClassDeclaration (P.TypeClassDeclaration _ _ _) = True +isTypeClassDeclaration P.TypeClassDeclaration{} = True isTypeClassDeclaration _ = False isTypeInstanceDeclaration :: P.Declaration -> Bool -isTypeInstanceDeclaration (P.TypeInstanceDeclaration _ _ _ _) = True +isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True isTypeInstanceDeclaration _ = False inputFile :: Term FilePath @@ -147,7 +147,7 @@ term = docgen <$> inputFile termInfo :: TermInfo termInfo = defTI { termName = "docgen" - , version = showVersion $ Paths.version + , version = showVersion Paths.version , termDoc = "Generate Markdown documentation from PureScript extern files" } diff --git a/prelude/prelude.purs b/prelude/prelude.purs index b22d78b..fea92d2 100644 --- a/prelude/prelude.purs +++ b/prelude/prelude.purs @@ -162,17 +162,14 @@ module Prelude where -- Referential equality data Ref a = Ref a - foreign import refEq "function refEq(r1) {\ - \ return function(r2) {\ - \ return r1.values[0] === r2.values[0];\ - \ };\ - \}" :: forall a. Ref a -> Ref a -> Boolean - - foreign import refIneq "function refIneq(r1) {\ - \ return function(r2) {\ - \ return r1.values[0] !== r2.values[0];\ - \ };\ - \}" :: forall a. Ref a -> Ref a -> Boolean + liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b + liftRef f (Ref x) (Ref y) = f x y + + refEq :: forall a. Ref a -> Ref a -> Boolean + refEq = liftRef unsafeRefEq + + refIneq :: forall a. Ref a -> Ref a -> Boolean + refIneq = liftRef unsafeRefIneq foreign import unsafeRefEq "function unsafeRefEq(r1) {\ \ return function(r2) {\ @@ -356,9 +353,10 @@ module Prelude where \ };\ \}" :: String -> String -> String -module Monoid where +module Data.Monoid where import Prelude + import Data.Array (foldl) infixr 6 <> @@ -372,16 +370,15 @@ module Monoid where instance Monoid [a] where mempty = [] - (<>) = Arrays.concat + (<>) = Data.Array.concat mconcat :: forall m. (Monoid m) => [m] -> m - mconcat [] = mempty - mconcat (m:ms) = m <> mconcat ms + mconcat = foldl (<>) mempty -module Monad where +module Control.Monad where import Prelude - import Arrays + import Data.Array replicateM :: forall m a. (Monad m) => Number -> m a -> m [a] replicateM 0 _ = return [] @@ -428,7 +425,7 @@ module Monad where when true m = m when false _ = return {} -module Maybe where +module Data.Maybe where import Prelude @@ -458,7 +455,7 @@ module Maybe where show (Just x) = "Just " ++ (show x) show Nothing = "Nothing" -module Either where +module Data.Either where import Prelude @@ -485,24 +482,18 @@ module Either where show (Left x) = "Left " ++ (show x) show (Right y) = "Right " ++ (show y) -module Arrays where +module Data.Array where import Prelude - import Maybe + import Data.Maybe - head :: forall a. [a] -> a - head (x : _) = x - - headSafe :: forall a. [a] -> Maybe a - headSafe (x : _) = Just x - headSafe _ = Nothing - - tail :: forall a. [a] -> [a] - tail (_ : xs) = xs + head :: forall a. [a] -> Maybe a + head (x : _) = Just x + head _ = Nothing - tailSafe :: forall a. [a] -> Maybe [a] - tailSafe (_ : xs) = Just xs - tailSafe _ = Nothing + tail :: forall a. [a] -> Maybe [a] + tail (_ : xs) = Just xs + tail _ = Nothing map :: forall a b. (a -> b) -> [a] -> [b] map _ [] = [] @@ -512,9 +503,9 @@ module Arrays where foldr f a (b : bs) = f (foldr f a bs) b foldr _ a [] = a - foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b + foldl :: forall a b. (b -> a -> b) -> b -> [a] -> b foldl _ b [] = b - foldl f b (a:as) = foldl f (f a b) as + foldl f b (a:as) = foldl f (f b a) as foreign import length "function length(xs) {\ \ return xs.length;\ @@ -582,15 +573,38 @@ module Arrays where \ return l1;\ \}" :: forall a. [a] -> [a] - foreign import splice "function splice(s) {\ - \ return function(e) {\ - \ return function(l1) {\ - \ return function(l2) {\ - \ return l2.splice(s, e, l1);\ - \ }; \ - \ }; \ - \ };\ - \}":: forall a. Number -> Number -> [a] -> [a] -> [a] + foreign import insertAt + "function insertAt(index) {\ + \ return function(a) {\ + \ return function(l) {\ + \ var l1 = l.slice();\ + \ l1.splice(index, 0, a);\ + \ return l1;\ + \ }; \ + \ };\ + \}":: forall a. Number -> a -> [a] -> [a] + + foreign import deleteAt + "function deleteAt(index) {\ + \ return function(n) {\ + \ return function(l) {\ + \ var l1 = l.slice();\ + \ l1.splice(index, n);\ + \ return l1;\ + \ }; \ + \ };\ + \}":: forall a. Number -> Number -> [a] -> [a] + + foreign import updateAt + "function updateAt(index) {\ + \ return function(a) {\ + \ return function(l) {\ + \ var l1 = l.slice();\ + \ l1[index] = a;\ + \ return l1;\ + \ }; \ + \ };\ + \}":: forall a. Number -> a -> [a] -> [a] infixr 6 : @@ -647,11 +661,19 @@ module Arrays where instance Prelude.Alternative [] where empty = [] (<|>) = concat + +module Data.Array.Unsafe where + + head :: forall a. [a] -> a + head (x : _) = x -module Tuples where + tail :: forall a. [a] -> [a] + tail (_ : xs) = xs + +module Data.Tuple where import Prelude - import Arrays + import Data.Array data Tuple a b = Tuple a b @@ -672,7 +694,7 @@ module Tuples where Tuple as bs -> Tuple (a : as) (b : bs) unzip [] = Tuple [] [] -module String where +module Data.String where foreign import lengthS "function lengthS(s) {\ \ return s.length;\ @@ -752,7 +774,7 @@ module String where \ return s.trim();\ \}" :: String -> String -module Regex where +module Data.String.Regex where foreign import data Regex :: * @@ -907,7 +929,7 @@ module Math where foreign import sqrt1_2 "var sqrt1_2 = Math.SQRT1_2;" :: Number foreign import sqrt2 "var sqrt2 = Math.SQRT2;" :: Number -module Eff where +module Control.Monad.Eff where foreign import data Eff :: # ! -> * -> * @@ -936,29 +958,29 @@ module Eff where (>>=) = bindEff foreign import untilE "function untilE(f) {\ - \ return function() {\ - \ while (!f()) { }\ - \ return {};\ - \ };\ + \ return function() {\ + \ while (!f()) { }\ + \ return {};\ + \ };\ \}" :: forall e. Eff e Boolean -> Eff e {} foreign import whileE "function whileE(f) {\ - \ return function(a) {\ - \ return function() {\ - \ while (f()) {\ + \ return function(a) {\ + \ return function() {\ + \ while (f()) {\ \ a();\ \ }\ - \ return {};\ + \ return {};\ \ };\ \ };\ \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {} foreign import forE "function forE(lo) {\ - \ return function(hi) {\ - \ return function(f) {\ - \ return function() {\ - \ for (var i = lo; i < hi; i++) {\ - \ f(i)();\ + \ return function(hi) {\ + \ return function(f) {\ + \ return function() {\ + \ for (var i = lo; i < hi; i++) {\ + \ f(i)();\ \ }\ \ };\ \ };\ @@ -967,9 +989,9 @@ module Eff where foreign import foreachE "function foreachE(as) {\ - \ return function(f) {\ - \ for (var i = 0; i < as.length; i++) {\ - \ f(as[i])();\ + \ return function(f) {\ + \ for (var i = 0; i < as.length; i++) {\ + \ f(as[i])();\ \ }\ \ };\ \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {} @@ -977,7 +999,7 @@ module Eff where module Random where - import Eff + import Control.Monad.Eff foreign import data Random :: ! @@ -985,9 +1007,9 @@ module Random where \ return Math.random();\ \}" :: forall e. Eff (random :: Random | e) Number -module Errors where +module Control.Monad.Error where - import Eff + import Control.Monad.Eff foreign import data Error :: * -> ! @@ -1009,9 +1031,9 @@ module Errors where \ };\ \}" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a -module IORef where +module Data.IORef where - import Eff + import Control.Monad.Eff foreign import data Ref :: ! @@ -1052,10 +1074,10 @@ module IORef where \ return f;\ \}" :: forall eff a. Eff (ref :: Ref | eff) a -> Eff eff a -module Trace where +module Debug.Trace where import Prelude - import Eff + import Control.Monad.Eff foreign import data Trace :: ! @@ -1069,9 +1091,9 @@ module Trace where print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {} print o = trace (show o) -module ST where +module Control.Monad.ST where - import Eff + import Control.Monad.Eff foreign import data ST :: * -> ! @@ -1145,9 +1167,9 @@ module ST where \ return f;\ \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a] -module Enum where +module Data.Enum where - import Maybe + import Data.Maybe class Enum a where toEnum :: Number -> Maybe a diff --git a/psc/Main.hs b/psc/Main.hs index 15dc7e2..86baae9 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -28,7 +28,7 @@ preludeFilename :: IO FilePath preludeFilename = Paths.getDataFileName "prelude/prelude.purs" readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module]) -readInput Nothing = getContents >>= return . P.runIndentParser "" P.parseModules +readInput Nothing = P.runIndentParser "" P.parseModules <$> getContents readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do text <- U.readFile inputFile return $ P.runIndentParser inputFile P.parseModules text @@ -118,7 +118,7 @@ term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile termInfo :: TermInfo termInfo = defTI { termName = "psc" - , version = showVersion $ Paths.version + , version = showVersion Paths.version , termDoc = "Compiles PureScript to Javascript" } diff --git a/psci/Commands.hs b/psci/Commands.hs new file mode 100644 index 0000000..28fc2b8 --- /dev/null +++ b/psci/Commands.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- +-- Module : Commands +-- Copyright : (c) Phil Freeman 2014 +-- License : MIT +-- +-- Maintainer : Phil Freeman <paf31@cantab.net> +-- Stability : experimental +-- Portability : +-- +-- | +-- Commands for PSCI. +-- +----------------------------------------------------------------------------- + +module Commands where + +import Language.PureScript + +-- | +-- Valid Meta-commands for PSCI +-- +data Command + -- | + -- A purescript expression + -- + = Expression Value + -- | + -- Show the help command + -- + | Help + -- | + -- Import a module from a loaded file + -- + | Import ModuleName + -- | + -- Load a file for use with importing + -- + | LoadFile FilePath + -- | + -- Exit PSCI + -- + | Quit + -- | + -- Reset the state of the REPL + -- + | Reset + -- | + -- Binds a value to a name + -- + | Let (Value -> Value) + -- | + -- Find the type of an expression + -- + | TypeOf Value + +-- | +-- The help menu. +-- +help :: [[String]] +help = + [ [":? ", "Show this help menu"] + , [":i <module> ", "Import <module> for use in PSCI"] + , [":m <file> ", "Load <file> for importing"] + , [":q ", "Quit PSCi"] + , [":r ", "Reset"] + , [":t <expr> ", "Show the type of <expr>"] + ] diff --git a/psci/Main.hs b/psci/Main.hs index 8909369..d29d294 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DoAndIfThenElse, FlexibleContexts #-} module Main where @@ -23,22 +23,29 @@ import Control.Applicative import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Control.Monad.Trans.State +import Control.Monad.Trans.State.Strict -import Data.List (intercalate, isPrefixOf, nub, sort) +import Data.List (intercalate, isPrefixOf, nub, sortBy) import Data.Maybe (mapMaybe) import Data.Traversable (traverse) +import Data.Version (showVersion) + +import Parser import System.Console.Haskeline -import System.Directory (findExecutable) +import System.Directory (doesFileExist, findExecutable, getHomeDirectory) import System.Exit import System.Environment.XDG.BaseDir +import System.FilePath ((</>), isPathSeparator) +import qualified System.Console.CmdTheLine as Cmd import System.Process +import Text.Parsec (ParseError) + +import qualified Data.Map as M import qualified Language.PureScript as P import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U (readFile) -import qualified Text.Parsec as Parsec (Parsec, eof) -- | -- The PSCI state. @@ -46,48 +53,45 @@ import qualified Text.Parsec as Parsec (Parsec, eof) -- The let bindings are partial, -- because it makes more sense to apply the binding to the final evaluated expression. -- -data PSCI = PSCI [P.ProperName] [P.Module] [P.Value -> P.Value] +data PSCiState = PSCiState + { psciImportedFilenames :: [FilePath] + , psciImportedModuleNames :: [P.ModuleName] + , psciLoadedModules :: [P.Module] + , psciLetBindings :: [P.Value -> P.Value] + } -- State helpers -- | --- Synonym to be more descriptive. --- This is just @lift@ --- -inputTToState :: InputT IO a -> StateT PSCI (InputT IO) a -inputTToState = lift - --- | --- Synonym to be more descriptive. --- This is just @lift . lift@ +-- Updates the state to have more imported modules. -- -ioToState :: IO a -> StateT PSCI (InputT IO) a -ioToState = lift . lift +updateImportedFiles :: FilePath -> PSCiState -> PSCiState +updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st } -- | -- Updates the state to have more imported modules. -- -updateImports :: String -> PSCI -> PSCI -updateImports name (PSCI i m b) = PSCI (i ++ [P.ProperName name]) m b +updateImports :: P.ModuleName -> PSCiState -> PSCiState +updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st } -- | -- Updates the state to have more loaded files. -- -updateModules :: [P.Module] -> PSCI -> PSCI -updateModules modules (PSCI i m b) = PSCI i (m ++ modules) b +updateModules :: [P.Module] -> PSCiState -> PSCiState +updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules } -- | -- Updates the state to have more let bindings. -- -updateLets :: (P.Value -> P.Value) -> PSCI -> PSCI -updateLets name (PSCI i m b) = PSCI i m (b ++ [name]) +updateLets :: (P.Value -> P.Value) -> PSCiState -> PSCiState +updateLets name st = st { psciLetBindings = psciLetBindings st ++ [name] } -- File helpers -- | -- Load the necessary modules. -- -defaultImports :: [P.ProperName] -defaultImports = [P.ProperName "Prelude"] +defaultImports :: [P.ModuleName] +defaultImports = [P.ModuleName [P.ProperName "Prelude"]] -- | -- Locates the node executable. @@ -95,7 +99,7 @@ defaultImports = [P.ProperName "Prelude"] -- findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names - where names = ["nodejs", "node"] + where names = ["nodejs", "node"] -- | -- Grabs the filename where the history is stored. @@ -113,10 +117,14 @@ getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs" -- Loads a file for use with imports. -- loadModule :: FilePath -> IO (Either String [P.Module]) -loadModule moduleFile = do - moduleText <- U.readFile moduleFile - return . either (Left . show) Right $ P.runIndentParser "" P.parseModules moduleText +loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename +-- | +-- Expands tilde in path. +-- +expandTilde :: FilePath -> IO FilePath +expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory +expandTilde p = return p -- Messages -- | @@ -154,23 +162,27 @@ quitMessage = "See ya!" -- | -- Loads module, function, and file completions. -- -completion :: [P.Module] -> CompletionFunc IO -completion ms = completeWord Nothing " \t\n\r" findCompletions +completion :: CompletionFunc (StateT PSCiState IO) +completion = completeWord Nothing " \t\n\r" findCompletions where - findCompletions :: String -> IO [Completion] + findCompletions :: String -> StateT PSCiState IO [Completion] findCompletions str = do + ms <- psciLoadedModules <$> get files <- listFiles str - let names = nub [ show qual - | P.Module moduleName ds <- ms - , ident <- mapMaybe getDeclName ds - , qual <- [ P.Qualified Nothing ident - , P.Qualified (Just moduleName) ident] - ] - let matches = sort $ filter (isPrefixOf str) names - return $ map simpleCompletion matches ++ files + let matches = filter (isPrefixOf str) (names ms) + return $ sortBy sorter $ map simpleCompletion matches ++ files getDeclName :: P.Declaration -> Maybe P.Ident getDeclName (P.ValueDeclaration ident _ _ _) = Just ident getDeclName _ = Nothing + names :: [P.Module] -> [String] + names ms = nub [ show qual + | P.Module moduleName ds <- ms + , ident <- mapMaybe getDeclName ds + , qual <- [ P.Qualified Nothing ident + , P.Qualified (Just moduleName) ident] + ] + sorter :: Completion -> Completion -> Ordering + sorter (Completion _ d1 _) (Completion _ d2 _) = compare d1 d2 -- Compilation @@ -182,93 +194,129 @@ options = P.Options True False True (Just "Main") True "PS" [] -- | -- Makes a volatile module to execute the current expression. -- -createTemporaryModule :: [P.ProperName] -> [P.Value -> P.Value] -> P.Value -> P.Module -createTemporaryModule imports lets value = +createTemporaryModule :: Bool -> [P.ModuleName] -> [P.Value -> P.Value] -> P.Value -> P.Module +createTemporaryModule exec imports lets value = let moduleName = P.ModuleName [P.ProperName "Main"] importDecl m = P.ImportDeclaration m Nothing - traceModule = P.ModuleName [P.ProperName "Trace"] + traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"] trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print")) value' = foldr ($) value lets - mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing (P.App trace value') + itDecl = P.ValueDeclaration (P.Ident "it") [] Nothing value' + mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing (P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))) in - P.Module moduleName $ map (importDecl . P.ModuleName . return) imports ++ [mainDecl] + P.Module moduleName $ map importDecl imports ++ if exec then [itDecl, mainDecl] else [itDecl] -- | -- Takes a value declaration and evaluates it with the current state. -- -handleDeclaration :: P.Value -> PSCI -> InputT IO () -handleDeclaration value (PSCI imports loadedModules lets) = do - let m = createTemporaryModule imports lets value - case P.compile options (loadedModules ++ [m]) of +handleDeclaration :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) () +handleDeclaration value st = do + let m = createTemporaryModule True (psciImportedModuleNames st) (psciLetBindings st) value + case P.compile options (psciLoadedModules st ++ [m]) of Left err -> outputStrLn err Right (js, _, _) -> do - process <- lift findNodeProcess - result <- lift $ traverse (\node -> readProcessWithExitCode node [] js) process + process <- lift . lift $ findNodeProcess + result <- lift . lift $ traverse (\node -> readProcessWithExitCode node [] js) process case result of Just (ExitSuccess, out, _) -> outputStrLn out Just (ExitFailure _, _, err) -> outputStrLn err Nothing -> outputStrLn "Couldn't find node.js" --- Parser helpers - -- | --- Parser for our PSCI version of @let@. --- This is essentially let from do-notation. --- However, since we don't support the @Eff@ monad, we actually want the normal @let@. +-- Takes a value and prints its type -- -parseLet :: Parsec.Parsec String P.ParseState (P.Value -> P.Value) -parseLet = P.Let <$> (P.reserved "let" *> P.indented *> P.parseBinder) - <*> (P.indented *> P.reservedOp "=" *> P.parseValue) +handleTypeOf :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) () +handleTypeOf value st = do + let m = createTemporaryModule False (psciImportedModuleNames st) (psciLetBindings st) value + case P.compile options { P.optionsMain = Nothing } (psciLoadedModules st ++ [m]) of + Left err -> outputStrLn err + Right (_, _, env') -> + case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of + Just (ty, _) -> outputStrLn . P.prettyPrintType $ ty + Nothing -> outputStrLn "Could not find type" + +-- Commands -- | --- Parser for any other valid expression. +-- Parses the input and returns either a Metacommand or an expression. -- -parseExpression :: Parsec.Parsec String P.ParseState P.Value -parseExpression = P.whiteSpace *> P.parseValue <* Parsec.eof - --- Commands +getCommand :: InputT (StateT PSCiState IO) (Either ParseError (Maybe Command)) +getCommand = do + firstLine <- getInputLine "> " + case firstLine of + Nothing -> return (Right Nothing) + Just s@ (':' : _) -> return . either Left (Right . Just) $ parseCommand s -- The start of a command + Just s -> either Left (Right . Just) . parseCommand <$> go [s] + where + go :: [String] -> InputT (StateT PSCiState IO) String + go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " -- | -- Performs an action for each meta-command given, and also for expressions.. -- -handleCommand :: Command -> StateT PSCI (InputT IO) () -handleCommand Empty = return () -handleCommand (Expression ls) = - case P.runIndentParser "" parseLet (unlines ls) of - Left _ -> - case P.runIndentParser "" parseExpression (unlines ls) of - Left err -> inputTToState $ outputStrLn (show err) - Right decl -> get >>= inputTToState . handleDeclaration decl - Right l -> modify (updateLets l) -handleCommand Help = inputTToState $ outputStrLn helpMessage -handleCommand (Import moduleName) = modify (updateImports moduleName) +handleCommand :: Command -> InputT (StateT PSCiState IO) () +handleCommand (Expression val) = lift get >>= handleDeclaration val +handleCommand (Let l) = lift $ modify (updateLets l) +handleCommand Help = outputStrLn helpMessage +handleCommand (Import moduleName) = lift $ modify (updateImports moduleName) handleCommand (LoadFile filePath) = do - mf <- ioToState $ loadModule filePath - case mf of - Left err -> inputTToState $ outputStrLn err - Right mf' -> modify (updateModules mf') -handleCommand Reload = do - (Right prelude) <- ioToState $ getPreludeFilename >>= loadModule - put (PSCI defaultImports prelude []) -handleCommand _ = inputTToState $ outputStrLn "Unknown command" + absPath <- lift . lift $ expandTilde filePath + exists <- lift . lift $ doesFileExist absPath + if exists then do + lift $ modify (updateImportedFiles absPath) + either outputStrLn (lift . modify . updateModules) =<< (lift . lift $ loadModule absPath) + else + outputStrLn $ "Couldn't locate: " ++ filePath +handleCommand Reset = do + preludeFilename <- lift . lift $ getPreludeFilename + files <- psciImportedFilenames <$> lift get + modulesOrFirstError <- fmap concat . sequence <$> mapM (lift . lift . loadModule) (preludeFilename : files) + case modulesOrFirstError of + Left err -> lift . lift $ putStrLn err >> exitFailure + Right modules -> lift $ put (PSCiState (preludeFilename : files) defaultImports modules []) +handleCommand (TypeOf val) = lift get >>= handleTypeOf val +handleCommand _ = outputStrLn "Unknown command" + +inputFiles :: Cmd.Term [FilePath] +inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)" + , Cmd.posDoc = "Optional .purs files to load on start" } -- | -- The PSCI main loop. -- -main :: IO () -main = do +loop :: [FilePath] -> IO () +loop files = do preludeFilename <- getPreludeFilename - (Right prelude) <- loadModule preludeFilename - historyFilename <- getHistoryFilename - let settings = defaultSettings {historyFile = Just historyFilename} - runInputT (setComplete (completion prelude) settings) $ do - outputStrLn prologueMessage - evalStateT go (PSCI defaultImports prelude []) - where - go :: StateT PSCI (InputT IO) () - go = do - c <- inputTToState getCommand - case c of - Quit -> inputTToState $ outputStrLn quitMessage - _ -> handleCommand c >> go + modulesOrFirstError <- fmap concat . sequence <$> mapM loadModule (preludeFilename : files) + case modulesOrFirstError of + Left err -> putStrLn err >> exitFailure + Right modules -> do + historyFilename <- getHistoryFilename + let settings = defaultSettings {historyFile = Just historyFilename} + flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do + outputStrLn prologueMessage + go + where + go :: InputT (StateT PSCiState IO) () + go = do + c <- getCommand + case c of + Left err -> outputStrLn (show err) >> go + Right Nothing -> go + Right (Just Quit) -> outputStrLn quitMessage + Right (Just c') -> handleCommand c' >> go + +term :: Cmd.Term (IO ()) +term = loop <$> inputFiles + +termInfo :: Cmd.TermInfo +termInfo = Cmd.defTI + { Cmd.termName = "psci" + , Cmd.version = showVersion Paths.version + , Cmd.termDoc = "Interactive mode for PureScript" + } + +main :: IO () +main = Cmd.run (term, termInfo) + diff --git a/psci/Parser.hs b/psci/Parser.hs new file mode 100644 index 0000000..e781683 --- /dev/null +++ b/psci/Parser.hs @@ -0,0 +1,92 @@ +----------------------------------------------------------------------------- +-- +-- Module : Parser +-- Copyright : (c) Phil Freeman 2014 +-- License : MIT +-- +-- Maintainer : Phil Freeman <paf31@cantab.net> +-- Stability : experimental +-- Portability : +-- +-- | +-- Parser for PSCI. +-- +----------------------------------------------------------------------------- + +module Parser ( + parseCommand + ) where + +import Commands + +import Data.Char (isSpace) + +import Control.Applicative hiding (many) + +import Text.Parsec hiding ((<|>)) + +import qualified Language.PureScript as P + +-- | +-- PSCI version of @let@. +-- This is essentially let from do-notation. +-- However, since we don't support the @Eff@ monad, +-- we actually want the normal @let@. +-- +psciLet :: Parsec String P.ParseState Command +psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> P.parseBinder) + <*> (P.indented *> P.reservedOp "=" *> P.parseValue)) + +-- | +-- Parses PSCI metacommands or expressions input from the user. +-- +parseCommand :: String -> Either ParseError Command +parseCommand = P.runIndentParser "" $ choice + [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf) + , try psciLet + , psciExpression + ] <* eof + +-- | +-- Parses expressions entered at the PSCI repl. +-- +psciExpression :: Parsec String P.ParseState Command +psciExpression = Expression <$> P.parseValue + +-- | +-- Parses 'Commands.Help' command. +-- +psciHelp :: Parsec String P.ParseState Command +psciHelp = Help <$ char '?' + +-- | +-- Parses 'Commands.Import' command. +-- +psciImport :: Parsec String P.ParseState Command +psciImport = Import <$> (char 'i' *> P.whiteSpace *> P.moduleName) + +-- | +-- Parses 'Commands.LoadFile' command. +-- +psciLoadFile :: Parsec String P.ParseState Command +psciLoadFile = LoadFile . trimEnd <$> (char 'm' *> P.whiteSpace *> manyTill anyChar eof) + where + trimEnd = reverse . dropWhile isSpace . reverse + +-- | +-- Parses 'Commands.Quit' command. +-- +psciQuit :: Parsec String P.ParseState Command +psciQuit = Quit <$ char 'q' + +-- | +-- Parses 'Commands.Reload' command. +-- +psciReload :: Parsec String P.ParseState Command +psciReload = Reset <$ char 'r' + +-- | +-- Parses 'Commands.TypeOf' command. +-- +psciTypeOf :: Parsec String P.ParseState Command +psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue) diff --git a/purescript.cabal b/purescript.cabal index fa60a8c..37b7294 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.4.2 +version: 0.4.2.1 cabal-version: >=1.8 build-type: Custom license: MIT @@ -84,14 +84,15 @@ executable psc ghc-options: -Wall -O2 -fno-warn-unused-do-bind executable psci - build-depends: base >=4 && <5, containers -any, directory -any, + build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, parsec -any, haskeline <=0.7.1.1, purescript -any, syb -any, transformers -any, utf8-string -any, process -any, - xdg-basedir -any + xdg-basedir -any, cmdtheline -any main-is: Main.hs buildable: True hs-source-dirs: psci - other-modules: + other-modules: Commands + Parser ghc-options: -Wall -O2 executable docgen diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs index 80ffede..f8f45b3 100644 --- a/src/Data/Generics/Extras.hs +++ b/src/Data/Generics/Extras.hs @@ -18,6 +18,7 @@ module Data.Generics.Extras where import Data.Data +import Data.Maybe (fromMaybe) -- | -- Apply a top-down monadic transformation everywhere @@ -26,3 +27,37 @@ everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d - everywhereM' f x = do y <- f x gmapM (everywhereM' f) y + +-- | +-- Apply a top-down transformation, mutating a state when descending from parents to children +-- +-- For example, if we want to relabel bound variables with a different data constructor, we can do so: +-- +-- > data Expr = Var String +-- > | Lam String Test +-- > | App Test Test +-- > | LocalVar String deriving (Show, Data, Typeable) +-- > +-- > test = App (Lam "a" (App (Var "a") (Var "b"))) (Var "a") +-- > +-- > varsToLocals :: Expr -> Expr +-- > varsToLocals = everywhereWithContext' [] (mkS go) +-- > where +-- > go locals (Var v) | v `elem` locals = (locals, LocalVar v) +-- > go locals lam@(Lam local _) = (local : locals, lam) +-- > go locals other = (locals, other) +-- +everywhereWithContext' :: (Data d) => s -> (forall d1. (Data d1) => s -> d1 -> (s, d1)) -> d -> d +everywhereWithContext' s0 f x = + let (s, y) = f s0 x in + gmapT (everywhereWithContext' s f) y + +-- | +-- Make a stateful transformation function +-- +mkS :: (Data a, Data b) => (s -> a -> (s, a)) -> s -> b -> (s, b) +mkS f s b = fromMaybe (s, b) $ do + a <- cast b + let (s', a') = f s a + b' <- cast a' + return (s', b') diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index b8378cb..5b2f7cf 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -22,6 +22,7 @@ import Language.PureScript.Declarations as P import Language.PureScript.Names as P import Language.PureScript.Parser as P import Language.PureScript.CodeGen as P +import Language.PureScript.CodeGen.Common as P import Language.PureScript.TypeChecker as P import Language.PureScript.Pretty as P import Language.PureScript.Sugar as P @@ -30,10 +31,9 @@ import Language.PureScript.ModuleDependencies as P import Language.PureScript.DeadCodeElimination as P import Data.List (intercalate) -import Data.Maybe (mapMaybe, fromMaybe) -import Control.Monad (when, forM) +import Data.Maybe (mapMaybe) import Control.Monad.State.Lazy -import Control.Applicative ((<$>), (<|>)) +import Control.Applicative ((<$>)) import qualified Data.Map as M -- | @@ -59,24 +59,20 @@ compile :: Options -> [Module] -> Either String (String, String, Environment) compile opts ms = do sorted <- sortModules ms desugared <- desugar sorted - (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do - modify (\s -> s { checkCurrentModule = Just moduleName }) - Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls + (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName' decls) -> do + modify (\s -> s { checkCurrentModule = Just moduleName' }) + Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated - let entryPoints = (ModuleName . splitProperNames) `map` optionsModules opts + let entryPoints = moduleNameFromString `map` optionsModules opts let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped let js = mapMaybe (flip (moduleToJs opts) env) elim - let exts = intercalate "\n" . map (flip moduleToPs env) $ elim - js' <- case optionsMain opts of - Just mainModuleName -> do - when ((ModuleName [ProperName mainModuleName], Ident "main") `M.notMember` (names env)) $ - Left $ mainModuleName ++ ".main is undefined" - return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []] + let exts = intercalate "\n" . map (`moduleToPs` env) $ elim + js' <- case mainModuleIdent of + Just mmi -> do + when ((mmi, Ident "main") `M.notMember` names env) $ + Left $ show mmi ++ ".main is undefined" + return $ js ++ [JSApp (JSAccessor "main" (JSAccessor (moduleNameToJs mmi) (JSVar "_ps"))) []] _ -> return js - return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env) + return (prettyPrintJS [wrapExportsContainer opts js'], exts, env) where - mainModuleIdent = ModuleName . splitProperNames <$> optionsMain opts - splitProperNames s = case dropWhile (== '.') s of - "" -> [] - s' -> ProperName w : splitProperNames s'' - where (w, s'') = break (== '.') s' + mainModuleIdent = moduleNameFromString <$> optionsMain opts diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/Common.hs index 0766256..288ba23 100644 --- a/src/Language/PureScript/CodeGen/Common.hs +++ b/src/Language/PureScript/CodeGen/Common.hs @@ -69,64 +69,66 @@ identCharToString c = '$' : show (ord c) -- nameIsJsReserved :: String -> Bool nameIsJsReserved name = - elem name [ "abstract" - , "boolean" - , "break" - , "byte" - , "case" - , "catch" - , "char" - , "class" - , "const" - , "continue" - , "debugger" - , "default" - , "delete" - , "do" - , "double" - , "else" - , "enum" - , "export" - , "extends" - , "final" - , "finally" - , "float" - , "for" - , "function" - , "goto" - , "if" - , "implements" - , "import" - , "in" - , "instanceof" - , "int" - , "interface" - , "let" - , "long" - , "native" - , "new" - , "package" - , "private" - , "protected" - , "public" - , "return" - , "short" - , "static" - , "super" - , "switch" - , "synchronized" - , "this" - , "throw" - , "throws" - , "transient" - , "try" - , "typeof" - , "var" - , "void" - , "volatile" - , "while" - , "with" - , "yield" ] + name `elem` [ "abstract" + , "arguments" + , "boolean" + , "break" + , "byte" + , "case" + , "catch" + , "char" + , "class" + , "const" + , "continue" + , "debugger" + , "default" + , "delete" + , "do" + , "double" + , "else" + , "enum" + , "eval" + , "export" + , "extends" + , "final" + , "finally" + , "float" + , "for" + , "function" + , "goto" + , "if" + , "implements" + , "import" + , "in" + , "instanceof" + , "int" + , "interface" + , "let" + , "long" + , "native" + , "new" + , "package" + , "private" + , "protected" + , "public" + , "return" + , "short" + , "static" + , "super" + , "switch" + , "synchronized" + , "this" + , "throw" + , "throws" + , "transient" + , "try" + , "typeof" + , "var" + , "void" + , "volatile" + , "while" + , "with" + , "yield" ] moduleNameToJs :: ModuleName -> String moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns) diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs index 52c6f2b..facf5e6 100644 --- a/src/Language/PureScript/CodeGen/Externs.hs +++ b/src/Language/PureScript/CodeGen/Externs.hs @@ -30,14 +30,14 @@ import Data.List (intercalate) -- moduleToPs :: Module -> Environment -> String moduleToPs (Module mn decls) env = - "module " ++ (runModuleName mn) ++ " where\n" ++ + "module " ++ runModuleName mn ++ " where\n" ++ (intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls) declToPs :: ModuleName -> Environment -> Declaration -> [String] declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do (ty, _) <- M.lookup (path, name) $ names env return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty -declToPs path env (BindingGroupDeclaration vals) = do +declToPs path env (BindingGroupDeclaration vals) = flip mapMaybe vals $ \(name, _) -> do (ty, _) <- M.lookup (path, name) $ names env return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index fde641a..ff9e47a 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -23,7 +23,6 @@ module Language.PureScript.CodeGen.JS ( ) where import Data.Maybe (fromMaybe, mapMaybe) -import Data.List (sortBy) import Data.Function (on) import Data.Data (Data) import Data.Generics (mkQ, everything) @@ -38,7 +37,6 @@ import Language.PureScript.Values import Language.PureScript.Names import Language.PureScript.Scope import Language.PureScript.Declarations -import Language.PureScript.Pretty.Common import Language.PureScript.CodeGen.Monad import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST as AST @@ -57,16 +55,16 @@ moduleToJs opts (Module name decls) env = [] -> Nothing _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $ JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"])) - [(JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral []))] + [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral [])] where - jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) (decls)) + jsDecls = concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls -- | -- Generate code in the simplified Javascript intermediate representation for a declaration -- declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS] declToJs opts mp (ValueDeclaration ident _ _ val) e = - Just $ [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val)) + Just [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val)) , setExportProperty ident (var ident) ] declToJs opts mp (BindingGroupDeclaration vals) e = Just $ concatMap (\(ident, val) -> @@ -85,8 +83,8 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ = (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))]) declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds -declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ = - Just $ [js, setExportProperty ident (var ident)] +declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ = + Just [js, setExportProperty ident (var ident)] declToJs _ _ _ _ = Nothing -- | @@ -94,7 +92,7 @@ declToJs _ _ _ _ = Nothing -- declaration from a module. -- setExportProperty :: Ident -> JS -> JS -setExportProperty ident val = JSAssignment (accessor ident (JSVar "module")) val +setExportProperty ident = JSAssignment (accessor ident (JSVar "module")) -- | -- Generate code in the simplified Javascript intermediate representation for a variable based on a @@ -194,12 +192,12 @@ runtimeTypeChecks arg ty = varToJs :: ModuleName -> Environment -> Qualified Ident -> JS varToJs m e qual@(Qualified _ ident) = go qual where - go qual = case M.lookup (qualify m qual) (names e) of + go qual' = case M.lookup (qualify m qual') (names e) of Just (_, ty) | isExtern ty -> var ident Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent) - _ -> case qual of + _ -> case qual' of Qualified Nothing _ -> var ident - _ -> qualifiedToJS m id qual + _ -> qualifiedToJS m id qual' isExtern (Extern ForeignImport) = True isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of Just (_, ty') -> isExtern ty' @@ -212,7 +210,7 @@ varToJs m e qual@(Qualified _ ident) = go qual -- qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar "_ps") -qualifiedToJS m f (Qualified _ a) = JSVar $ identToJs (f a) +qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a) -- | -- Generate code in the simplified Javascript intermediate representation for pattern match binders @@ -256,7 +254,7 @@ binderToJs _ _ varName done (BooleanBinder True) = return [JSIfElse (JSVar varName) (JSBlock done) Nothing] binderToJs _ _ varName done (BooleanBinder False) = return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing] -binderToJs m e varName done (VarBinder ident) = +binderToJs _ _ varName done (VarBinder ident) = return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done) binderToJs m e varName done (ConstructorBinder ctor bs) = do js <- go 0 done bs @@ -326,7 +324,7 @@ isOnlyConstructor m e ctor = typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn wrapExportsContainer :: Options -> [JS] -> JS -wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ (JSStringLiteral "use strict") : modules) [exportSelector] +wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ JSStringLiteral "use strict" : modules) [exportSelector] where exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module"))) (JSAccessor "exports" (JSVar "module")) diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs index b2bebce..d6b0d71 100644 --- a/src/Language/PureScript/CodeGen/Monad.hs +++ b/src/Language/PureScript/CodeGen/Monad.hs @@ -21,7 +21,6 @@ module Language.PureScript.CodeGen.Monad where import Control.Monad.State import Control.Applicative -import Language.PureScript.Names -- | -- Code generation monad data type diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs index 199d41d..f99b465 100644 --- a/src/Language/PureScript/CodeGen/Optimize.hs +++ b/src/Language/PureScript/CodeGen/Optimize.hs @@ -73,10 +73,10 @@ applyAll :: [a -> a] -> a -> a applyAll = foldl1 (.) untilFixedPoint :: (Eq a) => (a -> a) -> a -> a -untilFixedPoint f a = go a +untilFixedPoint f = go where - go a' = let a'' = f a' in - if a'' == a' then a'' else go a'' + go a = let a' = f a in + if a' == a then a' else go a' replaceIdent :: (Data d) => String -> JS -> d -> d replaceIdent var1 js = everywhere (mkT replace) @@ -100,7 +100,7 @@ isReassigned var1 = everything (||) (mkQ False check) check _ = False isRebound :: (Data d) => JS -> d -> Bool -isRebound js d = any (\var -> isReassigned var d) (everything (++) (mkQ [] variablesOf) js) +isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js) where variablesOf (JSVar var) = [var] variablesOf _ = [] @@ -135,25 +135,23 @@ shouldInline (JSAccessor _ val) = shouldInline val shouldInline (JSIndexer index val) = shouldInline index && shouldInline val shouldInline _ = False +removeFromBlock :: ([JS] -> [JS]) -> JS -> JS +removeFromBlock go (JSBlock sts) = JSBlock (go sts) +removeFromBlock _ js = js + inlineVariables :: JS -> JS -inlineVariables = everywhere (mkT removeFromBlock) +inlineVariables = everywhere (mkT $ removeFromBlock go) where - removeFromBlock :: JS -> JS - removeFromBlock (JSBlock sts) = JSBlock (go sts) - removeFromBlock js = js go :: [JS] -> [JS] go [] = [] - go (s@(JSVariableIntroduction var (Just js)) : sts) + go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) = go (replaceIdent var js sts) go (s:sts) = s : go sts removeUnusedVariables :: JS -> JS -removeUnusedVariables = everywhere (mkT removeFromBlock) +removeUnusedVariables = everywhere (mkT $ removeFromBlock go) where - removeFromBlock :: JS -> JS - removeFromBlock (JSBlock sts) = JSBlock (go sts) - removeFromBlock js = js go :: [JS] -> [JS] go [] = [] go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts @@ -165,8 +163,8 @@ etaConvert = everywhere (mkT convert) convert :: JS -> JS convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)]) | all shouldInline args && - not (any (flip isRebound block) (map JSVar idents)) && - not (or (map (flip isRebound block) args)) + not (any (`isRebound` block) (map JSVar idents)) && + not (any (`isRebound` block) args) = JSBlock (replaceIdents (zip idents args) body) convert js = js @@ -191,7 +189,7 @@ tco' = everywhere (mkT convert) copyVar :: String -> String copyVar arg = "__copy_" ++ arg convert :: JS -> JS - convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) = + convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) = let (argss, body', replace) = collectAllFunctionArgs [] id fn in case () of @@ -206,11 +204,11 @@ tco' = everywhere (mkT convert) collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) = collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) = - (args : allArgs, body, \b -> f (JSFunction ident (map copyVar args) b)) + (args : allArgs, body, f . JSFunction ident (map copyVar args)) collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) = collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) = - (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b))) + (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args)) collectAllFunctionArgs allArgs f body = (allArgs, body, f) isTailCall :: String -> JS -> Bool isTailCall ident js = @@ -312,19 +310,19 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert) isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True isRetPoly _ = False -- Check if an expression represents a function in the Ef module - isEffFunc name (JSAccessor name' (JSAccessor "Eff" (JSVar "_ps"))) | name == name' = True + isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True isEffFunc _ _ = False -- Module names prelude = ModuleName [ProperName "Prelude"] - effModule = ModuleName [ProperName "Eff"] + effModule = ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"] -- The name of the type class dictionary for the Monad Eff instance Right (Ident effDictName) = mkDictionaryValueName effModule (Qualified (Just prelude) (ProperName "Monad")) - (TypeConstructor (Qualified (Just effModule) (ProperName "Eff"))) + [TypeConstructor (Qualified (Just effModule) (ProperName "Eff"))] -- Check if an expression represents the Monad Eff dictionary isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True - isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True + isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True isEffDict _ = False -- Remove __do function applications which remain after desugaring undo :: JS -> JS @@ -345,7 +343,7 @@ inlineST = everywhere (mkT convertBlock) usages = findAllSTUsagesIn arg allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs - in everywhere (mkT $ convert allUsagesAreLocalVars) arg + in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg convertBlock other = other -- Convert a block in a safe way, preserving object wrappers of references, -- or in a more aggressive way, turning wrappers into local variables depending on the @@ -359,17 +357,17 @@ inlineST = everywhere (mkT convertBlock) convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f = if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref]) convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f = - (JSIndexer i arr) + JSIndexer i arr convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f = JSAssignment (JSIndexer i arr) val convert _ other = other -- Check if an expression represents a function in the ST module - isSTFunc name (JSAccessor name' (JSAccessor "ST" (JSVar "_ps"))) | name == name' = True + isSTFunc name (JSAccessor name' (JSAccessor "Control_Monad_ST" (JSVar "_ps"))) | name == name' = True isSTFunc _ _ = False -- Find all ST Refs initialized in this block findSTRefsIn = everything (++) (mkQ [] isSTRef) where - isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [arg]) []))) | isSTFunc "newSTRef" f = [ident] + isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident] isSTRef _ = [] -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage) @@ -400,7 +398,7 @@ inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS inlineOperator op f = everywhere (mkT convert) where convert :: JS -> JS - convert (JSApp (JSApp op [x]) [y]) | isOp op = f x y + convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y convert other = other isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True @@ -446,7 +444,7 @@ inlineCommonOperators = applyAll convert :: JS -> JS convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y convert other = other - isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar ps))) | longForm == identToJs (Op opString) = True + isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True isOp _ = False binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS @@ -470,5 +468,5 @@ inlineCommonOperators = applyAll Right (Ident dictName) = mkDictionaryValueName (ModuleName [ProperName "Prim"]) (Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className)) - ty + [ty] isOpDict _ _ _ = False diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs index 8de1cc4..0f3b297 100644 --- a/src/Language/PureScript/DeadCodeElimination.hs +++ b/src/Language/PureScript/DeadCodeElimination.hs @@ -35,19 +35,19 @@ eliminateDeadCode env entryPoints ms = let declarations = concatMap (declarationsByModule env) ms (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations - in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (moduleName) graph vertexFor entryPointVertices) ds) + in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds) type Key = (ModuleName, Either Ident ProperName) declarationsByModule :: Environment -> Module -> [(Key, [Key])] -declarationsByModule env (Module moduleName ds) = concatMap go $ ds +declarationsByModule env (Module moduleName ds) = concatMap go ds where go :: Declaration -> [(Key, [Key])] - go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env (moduleName) d)] + go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env moduleName d)] go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])] - go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names - go (DataBindingGroupDeclaration ds) = concatMap go ds + go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names' + go (DataBindingGroupDeclaration ds') = concatMap go ds' go _ = [] dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key] diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs index 934137c..3d73627 100644 --- a/src/Language/PureScript/Declarations.hs +++ b/src/Language/PureScript/Declarations.hs @@ -112,60 +112,60 @@ data Declaration -- | -- A type class declaration (name, argument, member declarations) -- - | TypeClassDeclaration ProperName String [Declaration] + | TypeClassDeclaration ProperName [String] [Declaration] -- | -- A type instance declaration (dependencies, class name, instance type, member declarations) -- - | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration] + | TypeInstanceDeclaration [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration] deriving (Show, D.Data, D.Typeable) -- | -- Test if a declaration is a value declaration -- isValueDecl :: Declaration -> Bool -isValueDecl (ValueDeclaration _ _ _ _) = True +isValueDecl ValueDeclaration{} = True isValueDecl _ = False -- | -- Test if a declaration is a data type or type synonym declaration -- isDataDecl :: Declaration -> Bool -isDataDecl (DataDeclaration _ _ _) = True -isDataDecl (TypeSynonymDeclaration _ _ _) = True +isDataDecl DataDeclaration{} = True +isDataDecl TypeSynonymDeclaration{} = True isDataDecl _ = False -- | -- Test if a declaration is a module import -- isImportDecl :: Declaration -> Bool -isImportDecl (ImportDeclaration _ _) = True +isImportDecl ImportDeclaration{} = True isImportDecl _ = False -- | -- Test if a declaration is a data type foreign import -- isExternDataDecl :: Declaration -> Bool -isExternDataDecl (ExternDataDeclaration _ _) = True +isExternDataDecl ExternDataDeclaration{} = True isExternDataDecl _ = False -- | -- Test if a declaration is a fixity declaration -- isFixityDecl :: Declaration -> Bool -isFixityDecl (FixityDeclaration _ _) = True +isFixityDecl FixityDeclaration{} = True isFixityDecl _ = False -- | -- Test if a declaration is a foreign import -- isExternDecl :: Declaration -> Bool -isExternDecl (ExternDeclaration _ _ _ _) = True +isExternDecl ExternDeclaration{} = True isExternDecl _ = False -- | -- Test if a declaration is a type class or instance declaration -- isTypeClassDeclaration :: Declaration -> Bool -isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True -isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True +isTypeClassDeclaration TypeClassDeclaration{} = True +isTypeClassDeclaration TypeInstanceDeclaration{} = True isTypeClassDeclaration _ = False diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 714e252..7b15f40 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -19,13 +19,10 @@ module Language.PureScript.ModuleDependencies ( import Data.Data import Data.Graph import Data.Generics -import Data.List (nub, intersect) -import Control.Applicative ((<$>)) +import Data.List (nub) import Language.PureScript.Declarations import Language.PureScript.Names -import Language.PureScript.Values -import Language.PureScript.Types -- | -- Sort a collection of modules based on module dependencies. diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 6fd6e0d..3f87e12 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -70,6 +70,14 @@ data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable) runModuleName :: ModuleName -> String runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns) +moduleNameFromString :: String -> ModuleName +moduleNameFromString = ModuleName . splitProperNames + where + splitProperNames s = case dropWhile (== '.') s of + "" -> [] + s' -> ProperName w : splitProperNames s'' + where (w, s'') = break (== '.') s' + instance Show ModuleName where show = runModuleName diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 6d35885..1ddcb3c 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -33,7 +33,7 @@ data Options = Options { , optionsMagicDo :: Bool -- | -- When specified, checks the type of `main` in the module, and generate a call to run main - -- after the module definitions. + -- after the module definitions. -- , optionsMain :: Maybe String -- | diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index c998e65..dde950d 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -48,8 +48,8 @@ reservedPsNames = [ "data" , "let" , "true" , "false" - , "until" , "in" + , "where" ] -- | @@ -328,7 +328,7 @@ buildPostfixParser fs first = do -- Parse an identifier in backticks or an operator -- parseIdentInfix :: P.Parsec String ParseState (Qualified Ident) -parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> Qualified Nothing <$> (Op <$> operator) +parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> Qualified Nothing <$> (Op <$> operator) -- | -- Mark the current indentation level diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 6571f28..6a0f4ee 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -20,11 +20,9 @@ module Language.PureScript.Parser.Declarations ( ) where import Data.Maybe (isJust, fromMaybe) -import Control.Monad (when) import Control.Applicative import qualified Text.Parsec as P -import Language.PureScript.Names import Language.PureScript.Parser.State import Language.PureScript.Parser.Common import Language.PureScript.Declarations @@ -32,7 +30,6 @@ import Language.PureScript.Parser.Values import Language.PureScript.Parser.Types import Language.PureScript.Parser.Kinds import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.Values parseDataDeclaration :: P.Parsec String ParseState Declaration parseDataDeclaration = do @@ -59,15 +56,15 @@ parseValueDeclaration = ValueDeclaration <$> parseIdent <*> P.many parseBinderNoParens <*> P.optionMaybe parseGuard - <*> ((lexeme (indented *> P.char '=')) *> parseValue) + <*> (lexeme (indented *> P.char '=') *> parseValue) parseExternDeclaration :: P.Parsec String ParseState Declaration -parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *> +parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *> (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName) <*> (lexeme (indented *> P.string "::") *> parseKind) <|> do ident <- parseIdent js <- P.optionMaybe (JSRaw <$> stringLiteral) - ty <- (lexeme (indented *> P.string "::") *> parsePolyType) + ty <- lexeme (indented *> P.string "::") *> parsePolyType return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty) parseAssociativity :: P.Parsec String ParseState Associativity @@ -89,29 +86,29 @@ parseImportDeclaration :: P.Parsec String ParseState Declaration parseImportDeclaration = do reserved "import" indented - moduleName <- moduleName + moduleName' <- moduleName idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName) - return $ ImportDeclaration moduleName idents + return $ ImportDeclaration moduleName' idents parseTypeClassDeclaration :: P.Parsec String ParseState Declaration parseTypeClassDeclaration = do reserved "class" className <- indented *> properName - ident <- indented *> identifier + idents <- indented *> P.many identifier indented *> reserved "where" members <- mark (P.many (same *> parseTypeDeclaration)) - return $ TypeClassDeclaration className ident members + return $ TypeClassDeclaration className idents members parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration parseTypeInstanceDeclaration = do reserved "instance" deps <- P.optionMaybe $ do - deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> parseType)) + deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom)) indented reservedOp "=>" return deps className <- indented *> parseQualified properName - ty <- indented *> parseType + ty <- indented *> P.many parseTypeAtom indented *> reserved "where" members <- mark (P.many (same *> parseValueDeclaration)) return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index ecd9bdc..314dd3c 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -51,15 +51,15 @@ parseObject = braces $ Object <$> parseRow False parseTypeVariable :: P.Parsec String ParseState Type parseTypeVariable = do ident <- identifier - when (ident `elem` reservedTypeNames) $ P.unexpected $ ident + when (ident `elem` reservedTypeNames) $ P.unexpected ident return $ TypeVar ident parseTypeConstructor :: P.Parsec String ParseState Type parseTypeConstructor = TypeConstructor <$> parseQualified properName parseForAll :: P.Parsec String ParseState Type -parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot) - <*> parseConstrainedType) +parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot) + <*> parseConstrainedType -- | -- Parse a type as it appears in e.g. a data constructor @@ -85,7 +85,7 @@ parseConstrainedType = do constraints <- parens . commaSep1 $ do className <- parseQualified properName indented - ty <- parseType + ty <- P.many parseTypeAtom return (className, ty) _ <- lexeme $ P.string "=>" return constraints @@ -94,7 +94,7 @@ parseConstrainedType = do return $ maybe ty (flip ConstrainedType ty) constraints parseAnyType :: P.Parsec String ParseState Type -parseAnyType = (P.buildExpressionParser operators $ parseTypeAtom) P.<?> "type" +parseAnyType = P.buildExpressionParser operators parseTypeAtom P.<?> "type" where operators = [ [ P.Infix (return TypeApp) P.AssocLeft ] , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ] @@ -112,9 +112,7 @@ parseType = do -- Parse a polytype -- parsePolyType :: P.Parsec String ParseState Type -parsePolyType = do - ty <- parseAnyType - return ty +parsePolyType = parseAnyType parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t) parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p @@ -123,5 +121,5 @@ parseRowEnding :: P.Parsec String ParseState Type parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier)) parseRow :: Bool -> P.Parsec String ParseState Type -parseRow nonEmpty = (curry rowFromList <$> (many $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row" - where many = if nonEmpty then commaSep1 else commaSep +parseRow nonEmpty = (curry rowFromList <$> many' (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row" + where many' = if nonEmpty then commaSep1 else commaSep diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs index 0ce9882..ad03dd3 100644 --- a/src/Language/PureScript/Parser/Values.hs +++ b/src/Language/PureScript/Parser/Values.hs @@ -20,13 +20,16 @@ module Language.PureScript.Parser.Values ( parseBinderNoParens, ) where +import Control.Applicative + import Language.PureScript.Values import Language.PureScript.Parser.State +import Language.PureScript.Parser.Types + +import Text.Parsec.Expr + import qualified Language.PureScript.Parser.Common as C -import Control.Applicative import qualified Text.Parsec as P -import Text.Parsec.Expr -import Language.PureScript.Parser.Types booleanLiteral :: P.Parsec String ParseState Bool booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False) @@ -59,7 +62,7 @@ parseAbs = do return $ toFunction args value where toFunction :: [Value -> Value] -> Value -> Value - toFunction args value = foldr (($)) value args + toFunction args value = foldr ($) value args parseVar :: P.Parsec String ParseState Value parseVar = Var <$> C.parseQualified C.parseIdent @@ -154,7 +157,7 @@ parseValue = indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom postfixTable1 = [ parseAccessor , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ] - postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= return . flip App) <*> pure v + postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v ] operators = [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident -> @@ -177,13 +180,13 @@ parseNullaryConstructorBinder :: P.Parsec String ParseState Binder parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure [] parseConstructorBinder :: P.Parsec String ParseState Binder -parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> (many (C.indented *> parseBinderNoParens)) +parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens) parseObjectBinder :: P.Parsec String ParseState Binder parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder)) parseArrayBinder :: P.Parsec String ParseState Binder -parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder)) +parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder) parseNamedBinder :: P.Parsec String ParseState Binder parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@')) @@ -203,7 +206,7 @@ parseIdentifierAndBinder = do -- Parse a binder -- parseBinder :: P.Parsec String ParseState Binder -parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression" +parseBinder = buildExpressionParser operators parseBinderAtom P.<?> "expression" where operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ] parseBinderAtom :: P.Parsec String ParseState Binder diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 35bf7e3..afb5da4 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -17,8 +17,6 @@ module Language.PureScript.Pretty.JS ( prettyPrintJS ) where -import Language.PureScript.Names -import Language.PureScript.Values import Language.PureScript.Pretty.Common import Language.PureScript.CodeGen.JS.AST @@ -69,7 +67,7 @@ literals = mkPattern' match , fmap (intercalate ", ") $ forM xs prettyPrintJS' , return " ]" ] - match (JSObjectLiteral []) = return "{}" + match (JSObjectLiteral []) = return "{}" match (JSObjectLiteral ps) = fmap concat $ sequence [ return "{\n" , withIndent $ do @@ -82,10 +80,7 @@ literals = mkPattern' match ] match (JSBlock sts) = fmap concat $ sequence [ return "{\n" - , withIndent $ do - jss <- forM sts prettyPrintJS' - indentString <- currentIndent - return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss + , withIndent $ prettyStatements sts , return "\n" , currentIndent , return "}" @@ -195,6 +190,12 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2) match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2) match' _ = Nothing +prettyStatements :: [JS] -> StateT PrinterState Maybe String +prettyStatements sts = do + jss <- forM sts prettyPrintJS' + indentString <- currentIndent + return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss + -- | -- Generate a pretty-printed string representing a Javascript expression -- @@ -205,10 +206,7 @@ prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (Print -- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level -- prettyPrintJS :: [JS] -> String -prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do - jss <- forM sts prettyPrintJS' - indentString <- currentIndent - return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss +prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements -- | -- Generate an indented, pretty-printed string representing a Javascript expression @@ -224,8 +222,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ] , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ] , [ Wrap lam $ \(name, args) ret -> "function " - ++ maybe "" id name - ++ "(" ++ (intercalate ", " args) ++ ") " + ++ fromMaybe "" name + ++ "(" ++ intercalate ", " args ++ ") " ++ ret ] , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ] , [ binary LessThan "<" ] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 2c9621e..c267f44 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -35,14 +35,14 @@ typeLiterals = mkPattern match match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }" match (TypeVar var) = Just var match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]" - match ty@(TypeConstructor ctor) = Just $ show ctor + match (TypeConstructor ctor) = Just $ show ctor match (TUnknown (Unknown u)) = Just $ 'u' : show u match (Skolem s _) = Just $ 's' : show s - match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty + match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ unwords (map prettyPrintType ty') ++ ")") deps) ++ ") => " ++ prettyPrintType ty match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">" match (ForAll ident ty _) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty match REmpty = Just "()" - match row@(RCons _ _ _) = Just $ '(' : prettyPrintRow row ++ ")" + match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")" match _ = Nothing -- | diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index f288174..6121322 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -38,7 +38,7 @@ literals = mkPattern match match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]" match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}" match (Constructor name) = Just $ show name - match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++ + match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++ " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }" match (Var ident) = Just $ show ident match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }" @@ -47,7 +47,7 @@ literals = mkPattern match prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++ - (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val + maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val ifThenElse :: Pattern () Value ((Value, Value), Value) ifThenElse = mkPattern match @@ -118,7 +118,7 @@ prettyPrintBinderAtom = mkPattern match match (BooleanBinder True) = Just "true" match (BooleanBinder False) = Just "false" match (VarBinder ident) = Just $ show ident - match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ intercalate " " (map (parens . prettyPrintBinder) args) + match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ unwords (map (parens . prettyPrintBinder) args) match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }" match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]" match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs index d6d0b0a..c2509dc 100644 --- a/src/Language/PureScript/Scope.hs +++ b/src/Language/PureScript/Scope.hs @@ -18,6 +18,8 @@ module Language.PureScript.Scope ( unusedNames ) where +import Control.Applicative ((<$>)) + import Data.Data import Data.List ((\\), nub) import Data.Generics (extQ, mkQ, everything) @@ -41,8 +43,8 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesB `extQ` namesJ namesB _ = [] namesJS :: JS -> [Ident] namesJS (JSVar name) = [Ident name] - namesJS (JSFunction (Just name) args _) = (Ident name) : (Ident `map` args) - namesJS (JSFunction Nothing args _) = (Ident `map` args) + namesJS (JSFunction (Just name) args _) = Ident name : (Ident <$> args) + namesJS (JSFunction Nothing args _) = Ident <$> args namesJS (JSVariableIntroduction name _) = [Ident name] namesJS (JSFor name _ _ _) = [Ident name] namesJS _ = [] diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index c933dc3..00b4732 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -69,7 +69,7 @@ createBindingGroups moduleName ds = do -- Collapse all binding groups to individual declarations -- collapseBindingGroups :: [Declaration] -> [Declaration] -collapseBindingGroups ds = concatMap go ds +collapseBindingGroups = concatMap go where go (DataBindingGroupDeclaration ds) = ds go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds @@ -112,10 +112,10 @@ toDataBindingGroup (CyclicSCC ds') | all isTypeSynonym ds' = Left "Cycle in type synonyms" | otherwise = return $ DataBindingGroupDeclaration ds' where - isTypeSynonym (TypeSynonymDeclaration _ _ _) = True + isTypeSynonym TypeSynonymDeclaration{} = True isTypeSynonym _ = False fromValueDecl :: Declaration -> (Ident, Value) fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val) -fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared" +fromValueDecl ValueDeclaration{} = error "Binders should have been desugared" fromValueDecl _ = error "Expected ValueDeclaration" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 3f02a72..d748648 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -75,7 +75,7 @@ makeCaseDeclaration ident alternatives = let argPattern = length . fst . head $ alternatives args = take argPattern $ unusedNames (ident, alternatives) - vars = map (\arg -> Var (Qualified Nothing arg)) args + vars = map (Var . Qualified Nothing) args binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ] value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args in diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 16fc125..c07ca08 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -27,13 +27,17 @@ import Language.PureScript.Names import Language.PureScript.Declarations import Language.PureScript.Values +import Control.Applicative +import Control.Arrow (first) +import Control.Monad.State + import Data.Function (on) import Data.List (groupBy, sortBy) + import qualified Data.Map as M import qualified Data.Generics as G import qualified Data.Generics.Extras as G -import Control.Monad.State -import Control.Applicative + import qualified Text.Parsec as P import qualified Text.Parsec.Pos as P import qualified Text.Parsec.Expr as P @@ -62,9 +66,9 @@ customOperatorTable fixities = -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to -- make sure that the generated code is correct. - applyUserOp (Qualified _ name) t1 t2 = App (App (Var (Qualified Nothing name)) t1) t2 + applyUserOp (Qualified _ name) t1 = App (App (Var (Qualified Nothing name)) t1) userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities - sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps + sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted in map (map (\(name, f, _, a) -> (name, f, a))) groups @@ -72,10 +76,10 @@ customOperatorTable fixities = type Chain = [Either Value (Qualified Ident)] matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value -matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val +matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains) where parseChains :: Value -> Either String Value - parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b) + parseChains b@BinaryNoParens{} = bracketChain (extendChain b) parseChains other = return other extendChain :: Value -> Chain extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r @@ -108,7 +112,7 @@ collectFixities m moduleName (FixityDeclaration fixity name : rest) = do collectFixities (M.insert qual fixity m) moduleName rest collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ] - let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs) - collectFixities (M.union m' m) moduleName rest + let m' = M.fromList (map (first (Qualified (Just moduleName))) fs) + collectFixities (m' `M.union` m) moduleName rest collectFixities m moduleName (_:ds) = collectFixities m moduleName ds diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 90926f7..f0ad912 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -31,14 +31,12 @@ import qualified Data.Map as M import Control.Applicative import Control.Monad.State -import Control.Arrow ((***)) +import Control.Arrow (second) -import Data.Maybe (fromMaybe) -import Data.List (nub) -import Data.Generics (mkQ, everything) +import Data.List (intercalate) import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs) -type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)]) +type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)]) type Desugar = StateT MemberMap (Either String) @@ -91,10 +89,10 @@ desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl -- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) } -- desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration] -desugarDecl mn d@(TypeClassDeclaration name arg members) = do +desugarDecl mn d@(TypeClassDeclaration name args members) = do let tys = map memberToNameAndType members - modify (M.insert (mn, name) (arg, tys)) - return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members + modify (M.insert (mn, name) (args, tys)) + return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor name args) members desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do desugared <- lift $ desugarCases members entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared @@ -106,50 +104,50 @@ memberToNameAndType :: Declaration -> (String, Type) memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty) memberToNameAndType _ = error "Invalid declaration in type class definition" -typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration -typeClassDictionaryDeclaration name arg members = - TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty)) +typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration +typeClassDictionaryDeclaration name args members = + TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty)) -typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration -typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) = +typeClassMemberToDictionaryAccessor :: ProperName -> [String] -> Declaration -> Declaration +typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) = ExternDeclaration TypeClassAccessorImport ident (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))]))) - (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty) Nothing) + (quantify (ConstrainedType [(Qualified Nothing name, map TypeVar args)] ty)) typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition" -typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration -typeInstanceDictionaryDeclaration mn deps name ty decls = do +typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration +typeInstanceDictionaryDeclaration mn deps name tys decls = do m <- get - (arg, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right + (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn name) m - let memberTypes = map (id *** replaceTypeVars arg ty) instanceTys - entryName <- lift $ mkDictionaryValueName mn name ty + let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys + entryName <- lift $ mkDictionaryValueName mn name tys memberNames <- mapM (memberToNameAndValue memberTypes) decls return $ ValueDeclaration entryName [] Nothing (TypedValue True - (foldr Abs (ObjectLiteral memberNames) (map (\n -> Left . Ident $ '_' : show n) [1..max 1 (length deps)])) + (foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)]) (quantify (if null deps then - function unit (TypeApp (TypeConstructor name) ty) + function unit (foldl TypeApp (TypeConstructor name) tys) else - foldr function (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps))) + foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor name) tys) deps)) ) where memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value) - memberToNameAndValue tys (ValueDeclaration ident _ _ _) = do - memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys - memberName <- mkDictionaryEntryName mn name ty ident + memberToNameAndValue tys' (ValueDeclaration ident _ _ _) = do + memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys' + memberName <- mkDictionaryEntryName mn name tys ident return (identToJs ident, TypedValue False (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps])) (quantify memberType)) memberToNameAndValue _ _ = error "Invalid declaration in type instance definition" -typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration -typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do +typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration +typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident [] _ val) = do m <- get - valTy <- lift $ do (arg, members) <- lookupTypeClass m + valTy <- lift $ do (args, members) <- lookupTypeClass m ty' <- lookupIdent members - return $ replaceTypeVars arg ty ty' - entryName <- mkDictionaryEntryName mn name ty ident + return $ replaceAllTypeVars (zip args tys) ty' + entryName <- mkDictionaryEntryName mn name tys ident return $ ValueDeclaration entryName [] Nothing (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy))) where @@ -164,10 +162,10 @@ qualifiedToString _ (Qualified (Just mn) pn) = moduleNameToJs mn ++ "_" ++ runPr -- | -- Generate a name for a type class dictionary, based on the module name, class name and type name -- -mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Either String Ident -mkDictionaryValueName mn cl ty = do - tyStr <- typeToString mn ty - return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr +mkDictionaryValueName :: ModuleName -> Qualified ProperName -> [Type] -> Either String Ident +mkDictionaryValueName mn cl tys = do + tyStr <- mapM (typeToString mn) tys + return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ intercalate "_" tyStr typeToString :: ModuleName -> Type -> Either String String typeToString _ (TypeVar _) = return "var" @@ -179,7 +177,7 @@ typeToString _ _ = Left "Type class instance must be of the form T a1 ... an" -- Generate a name for a type class dictionary member, based on the module name, class name, type name and -- member name -- -mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident -mkDictionaryEntryName mn name ty ident = do - Ident dictName <- lift $ mkDictionaryValueName mn name ty +mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> [Type] -> Ident -> Desugar Ident +mkDictionaryEntryName mn name tys ident = do + Ident dictName <- lift $ mkDictionaryValueName mn name tys return $ Escaped $ dictName ++ "_" ++ identToJs ident diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 985ced7..012794b 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -86,7 +86,7 @@ addValue moduleName name ty = do putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) }) addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check () -addTypeClassDictionaries entries = do +addTypeClassDictionaries entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } } checkTypeClassInstance :: ModuleName -> Type -> Check () @@ -154,7 +154,7 @@ typeCheckAll mainModuleName moduleName (ValueDeclaration name [] Nothing val : r return $ ValueDeclaration name [] Nothing val' ds <- typeCheckAll mainModuleName moduleName rest return $ d : ds -typeCheckAll _ _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared" +typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared" typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do forM_ (map fst vals) $ \name -> @@ -206,7 +206,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident filterModule = filter ((== moduleName) . fst) . M.keys moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env))) shadowIdents idents' env = - forM_ idents' $ \ident -> do + forM_ idents' $ \ident -> case (moduleName, ident) `M.lookup` names env of Just (_, Alias _ _) -> return () Just (pt, _) -> do @@ -214,7 +214,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) }) Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined") shadowTypes pns env = - forM_ pns $ \pn -> do + forM_ pns $ \pn -> case (moduleName, pn) `M.lookup` types env of Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined") Just (_, DataAlias _ _) -> return () @@ -222,7 +222,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) }) let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env - forM_ keys $ \dctor -> do + forM_ keys $ \dctor -> case (moduleName, dctor) `M.lookup` dataConstructors env of Just (_, Alias _ _) -> return () Just (ctorTy, _) -> do @@ -236,23 +236,23 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident ) (typeClassDictionaries env) forM_ instances $ \tcd -> do let (Qualified _ ident) = tcdName tcd - addTypeClassDictionaries [tcd { tcdName = (Qualified (Just currentModule) ident), tcdType = TCDAlias (tcdName tcd) }] + addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }] constructs (TypeConstructor (Qualified (Just mn) pn')) pn = mn == moduleName && pn' == pn constructs (ForAll _ ty _) pn = ty `constructs` pn constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn constructs (TypeApp ty _) pn = ty `constructs` pn constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn -typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do +typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do env <- getEnv ds <- typeCheckAll mainModuleName moduleName rest return $ qualifyAllUnqualifiedNames moduleName env d : ds -typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do +typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className tys _) : rest) = do env <- getEnv - dictName <- Check . lift $ mkDictionaryValueName moduleName className ty - checkTypeClassInstance moduleName ty - forM_ deps $ checkTypeClassInstance moduleName . snd + dictName <- Check . lift $ mkDictionaryValueName moduleName className tys + mapM_ (checkTypeClassInstance moduleName) tys + forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env - [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular]) + [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]) ds <- typeCheckAll mainModuleName moduleName rest return $ qualifyAllUnqualifiedNames moduleName env d : ds diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 3283520..068faf4 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -14,7 +14,6 @@ ----------------------------------------------------------------------------- {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} module Language.PureScript.TypeChecker.Kinds ( @@ -31,7 +30,6 @@ import Language.PureScript.Pretty import Control.Monad.State import Control.Monad.Error -import Control.Monad.Reader import Control.Monad.Unify import Control.Applicative @@ -59,7 +57,7 @@ instance Unifiable Check Kind where -- Infer the kind of a single type -- kindOf :: ModuleName -> Type -> Check Kind -kindOf moduleName ty = +kindOf _ ty = rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $ fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty where @@ -87,8 +85,8 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars bindLocalTypeVariables moduleName dict $ do tyCons <- replicateM (length tys) fresh - let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons - bindLocalTypeVariables moduleName dict $ do + let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons + bindLocalTypeVariables moduleName dict' $ do data_ks <- zipWithM (\tyCon (_, args, ts) -> do kargs <- replicateM (length args) fresh let argDict = zip (map ProperName args) kargs @@ -159,7 +157,9 @@ infer (RCons _ ty row) = do k2 =?= Row k1 return $ Row k1 infer (ConstrainedType deps ty) = do - mapM_ (infer . snd) deps + forM_ deps $ \(className, tys) -> do + _ <- infer $ foldl TypeApp (TypeConstructor className) tys + return () k <- infer ty k =?= Star return Star diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index c206590..6d9b73c 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -13,8 +13,8 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes, DeriveDataTypeable, - GADTs, StandaloneDeriving, MultiParamTypeClasses, FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes, + MultiParamTypeClasses, FlexibleContexts #-} module Language.PureScript.TypeChecker.Monad where @@ -26,15 +26,13 @@ import Language.PureScript.Declarations import Data.Data import Data.Maybe -import Data.Monoid import Data.Generics (mkT, everywhere) import Control.Applicative import Control.Monad.State import Control.Monad.Error -import Control.Monad.Reader import Control.Monad.Unify -import Control.Arrow ((***)) +import Control.Arrow (first) import qualified Data.Map as M @@ -173,15 +171,15 @@ getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get -- Temporarily bind a collection of names to local variables -- bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a -bindLocalVariables moduleName bindings action = - bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action +bindLocalVariables moduleName bindings = + bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) -- | -- Temporarily bind a collection of names to local type variables -- bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a -bindLocalTypeVariables moduleName bindings action = - bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action +bindLocalTypeVariables moduleName bindings = + bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) -- | -- Lookup the type of a value by name in the @Environment@ @@ -322,7 +320,7 @@ liftUnify unify = do case e of Left err -> throwError err Right (a, ust) -> do - modify $ \st -> st { checkNextVar = unifyNextVar ust } + modify $ \st' -> st' { checkNextVar = unifyNextVar ust } return (a, unifyCurrentSubstitution ust) -- | @@ -334,7 +332,7 @@ qualifyAllUnqualifiedNames mn env = everywhere (mkT go) go :: Type -> Type go (TypeConstructor nm) = TypeConstructor $ qualify' nm go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args - go (ConstrainedType constraints ty) = ConstrainedType (map (qualify' *** id) constraints) ty + go (ConstrainedType constraints ty) = ConstrainedType (map (first qualify') constraints) ty go other = other qualify' qual = let (mn', pn') = canonicalizeType mn env qual in Qualified (Just mn') pn' diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 01f302e..0a3a9f2 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -14,7 +14,6 @@ ----------------------------------------------------------------------------- {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -60,7 +59,6 @@ import Language.PureScript.Pretty import Control.Monad.State import Control.Monad.Error -import Control.Monad.Reader import Control.Monad.Unify import Control.Applicative @@ -82,7 +80,7 @@ instance Unifiable Check Type where -- Unify two types, updating the current substitution -- unifyTypes :: Type -> Type -> UnifyT Type Check () -unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do +unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ unifyTypes' t1 t2 where unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () @@ -104,8 +102,8 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 + sko <- newSkolemConstant let sk = skolemize ident sko sc ty1 sk `unifyTypes` ty2 - unifyTypes' (ForAll _ _ _) _ = throwError "Skolem variable scope is unspecified" - unifyTypes' ty f@(ForAll _ _ _) = f `unifyTypes` ty + unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified" + unifyTypes' ty f@ForAll{} = f `unifyTypes` ty unifyTypes' (Object row1) (Object row2) = row1 =?= row2 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return () unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do @@ -116,8 +114,8 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 + t3 `unifyTypes` t5 t4 `unifyTypes` t6 unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return () - unifyTypes' r1@(RCons _ _ _) r2 = unifyRows r1 r2 - unifyTypes' r1 r2@(RCons _ _ _) = unifyRows r1 r2 + unifyTypes' r1@RCons{} r2 = unifyRows r1 r2 + unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 unifyTypes' r1@REmpty r2 = unifyRows r1 r2 unifyTypes' r1 r2@REmpty = unifyRows r1 r2 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "." @@ -187,30 +185,30 @@ typesOf mainModuleName moduleName vals = do -- If the declaration is a function, it has access to other values in the binding group. -- If not, the generated code might fail at runtime since those values might be undefined. let dict' = if isFunction val then dict else M.empty - triple@(_, (val, ty)) <- case e of + triple@(_, (val', ty)) <- case e of -- Typed declarations - (ident, (val, Just (ty, checkType))) -> do + (ident, (val', Just (ty, checkType))) -> do -- Kind check kind <- liftCheck $ kindOf moduleName ty guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star -- Check the type with the new names in scope ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty - val' <- bindNames dict' $ if checkType - then TypedValue True <$> check val ty' <*> pure ty' - else return (TypedValue False val ty') - return (ident, (val', ty')) + val'' <- bindNames dict' $ if checkType + then TypedValue True <$> check val' ty' <*> pure ty' + else return (TypedValue False val' ty') + return (ident, (val'', ty')) -- Untyped declarations - (ident, (val, Nothing)) -> do + (ident, (val', Nothing)) -> do -- Infer the type with the new names in scope - TypedValue _ val' ty <- bindNames dict' $ infer val + TypedValue _ val'' ty <- bindNames dict' $ infer val' ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict) - return (ident, (TypedValue True val' ty, ty)) + return (ident, (TypedValue True val'' ty, ty)) -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a when (Just moduleName == mainModuleName && fst e == Ident "main") $ do [eff, a] <- replicateM 2 fresh - ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Eff"])) (ProperName "Eff"))) eff) a + ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a -- Make sure unification variables do not escape - escapeCheck val ty + escapeCheck val' ty return triple forM tys $ \(ident, (val, ty)) -> do -- Replace type class dictionary placeholders with actual dictionaries @@ -221,7 +219,7 @@ typesOf mainModuleName moduleName vals = do -- top-level unification variables with named type variables. let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val' ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty - return $ (ident, (val'', ty')) + return (ident, (val'', ty')) where -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts @@ -260,14 +258,14 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go) -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. -- -entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value -entails moduleName context goal@(className, ty) = do +entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value +entails moduleName context goal@(className, tys) = do env <- getEnv case go env goal of - [] -> throwError $ "No " ++ show className ++ " instance found for " ++ prettyPrintType ty + [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys) (dict : _) -> return dict where - go env (className', ty') = + go env (className', tys') = [ mkDictionary (canonicalizeDictionary tcd) args | tcd <- context -- Choose type class dictionaries in scope in the current module @@ -275,16 +273,16 @@ entails moduleName context goal@(className, ty) = do -- Make sure the type class name matches the one we are trying to satisfy , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd) -- Make sure the type unifies with the type in the type instance definition - , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd) + , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd) -- Solve any necessary subgoals , args <- solveSubgoals env subst (tcdDependencies tcd) ] -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, Type)] -> [Maybe [Value]] + solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]] solveSubgoals _ _ Nothing = return Nothing solveSubgoals env subst (Just subgoals) = do - dict <- mapM (go env) (map (id *** replaceAllTypeVars subst) subgoals) + dict <- mapM (go env . second (map (replaceAllTypeVars subst))) subgoals return $ Just dict -- Make a dictionary from subgoal dictionaries by applying the correct function mkDictionary :: Qualified Ident -> Maybe [Value] -> Value @@ -301,6 +299,12 @@ entails moduleName context goal@(className, ty) = do canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm + -- Ensure that a substitution is valid + verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)] + verifySubstitution subst = do + let grps = groupBy ((==) `on` fst) subst + guard (all ((==) 1 . length . nubBy ((==) `on` snd)) grps) + return $ map head grps -- | -- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup), @@ -314,7 +318,7 @@ typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructo typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2 typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1 typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of - Left err -> Nothing + Left _ -> Nothing Right t1 -> typeHeadsAreEqual m e t1 t2 typeHeadsAreEqual _ _ _ _ = Nothing @@ -344,7 +348,7 @@ findAllTypes = everything (++) (mkQ [] go) -- skolemEscapeCheck :: Value -> Check () skolemEscapeCheck (TypedValue False _ _) = return () -skolemEscapeCheck root@(TypedValue _ _ _) = +skolemEscapeCheck root@TypedValue{} = -- Every skolem variable is created when a ForAll type is skolemized. -- This determines the scope of that skolem variable, which is copied from the SkolemScope -- field of the ForAll constructor. @@ -368,10 +372,10 @@ skolemEscapeCheck root@(TypedValue _ _ _) = collect _ = [] go _ scos = ([], scos) findBindingScope :: SkolemScope -> Maybe Value - findBindingScope sco = something (mkQ Nothing go) root + findBindingScope sco = something (mkQ Nothing go') root where - go val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val - go _ = Nothing + go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val + go' _ = Nothing skolemEscapeCheck val = throwError $ "Untyped value passed to skolemEscapeCheck: " ++ prettyPrintValue val -- | @@ -393,19 +397,13 @@ varIfUnknown :: Type -> Type varIfUnknown ty = let unks = nub $ unknowns ty toName = (:) 't' . show - ty' = everywhere (mkT typeToVar) $ ty + ty' = everywhere (mkT typeToVar) ty typeToVar :: Type -> Type typeToVar (TUnknown (Unknown u)) = TypeVar (toName u) typeToVar t = t in mkForAll (sort . map (toName . runUnknown) $ unks) ty' -- | --- Replace named type variables with types --- -replaceAllTypeVars :: [(String, Type)] -> Type -> Type -replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id - --- | -- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns -- or TypeClassDictionary values. -- @@ -430,7 +428,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty) replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type replaceVarWithUnknown ident ty = do tu <- fresh - return $ replaceTypeVars ident tu $ ty + return $ replaceTypeVars ident tu ty -- | -- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate @@ -603,11 +601,11 @@ inferBinder val (ConstructorBinder ctor binders) = do (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty go binders fn where - go [] ty = do - subsumes Nothing val ty + go [] ty' = do + subsumes Nothing val ty' return M.empty - go (binder : binders) (TypeApp (TypeApp t obj) ret) | t == tyFunction = - M.union <$> inferBinder obj binder <*> go binders ret + go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction = + M.union <$> inferBinder obj binder <*> go binders' ret go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined" inferBinder val (ObjectBinder props) = do @@ -713,7 +711,7 @@ check val ty = rethrow errorMessage $ check' val ty -- Check the type of a value -- check' :: Value -> Type -> UnifyT Type Check Value -check' val t@(ForAll ident ty _) = do +check' val (ForAll ident ty _) = do scope <- newSkolemScope sko <- newSkolemConstant let sk = skolemize ident sko scope ty @@ -722,15 +720,15 @@ check' val t@(ForAll ident ty _) = do check' val t@(ConstrainedType constraints ty) = do env <- getEnv Just moduleName <- checkCurrentModule <$> get - dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do + dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do n <- liftCheck freshDictionaryName return $ Ident $ "__dict_" ++ className ++ "_" ++ show n val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames) (qualifyAllUnqualifiedNames moduleName env constraints)) $ check val ty - return $ TypedValue True (foldr Abs val' (map Left dictNames)) t -check' val t@(SaturatedTypeSynonym name args) = do + return $ TypedValue True (foldr (Abs . Left) val' dictNames) t +check' val (SaturatedTypeSynonym name args) = do ty <- introduceSkolemScope <=< expandTypeSynonym name $ args val' <- check val ty return $ TypedValue True val' ty @@ -747,8 +745,8 @@ check' v@(StringLiteral _) t | t == tyString = check' v@(BooleanLiteral _) t | t == tyBoolean = return $ TypedValue True v t check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do - arr <- ArrayLiteral <$> forM vals (\val -> check val ty) - return $ TypedValue True arr t + array <- ArrayLiteral <$> forM vals (`check` ty) + return $ TypedValue True array t check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do Just moduleName <- checkCurrentModule <$> get ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy @@ -944,17 +942,17 @@ subsumes' val (Object r1) (Object r2) = do go ts1' ts2' r1' r2' return val where - go [] ts2 r1 r2 = r1 =?= rowFromList (ts2, r2) - go ts1 [] r1 r2 = r2 =?= rowFromList (ts1, r1) - go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1 r2 + go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2') + go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1') + go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2' | p1 == p2 = do subsumes Nothing ty1 ty2 - go ts1 ts2 r1 r2 + go ts1 ts2 r1' r2' | p1 < p2 = do rest <- fresh - r2 =?= RCons p1 ty1 rest - go ts1 ((p2, ty2) : ts2) r1 rest + r2' =?= RCons p1 ty1 rest + go ts1 ((p2, ty2) : ts2) r1' rest | p1 > p2 = do rest <- fresh - r1 =?= RCons p2 ty2 rest - go ((p1, ty1) : ts1) ts2 rest r2 + r1' =?= RCons p2 ty2 rest + go ((p1, ty1) : ts1) ts2 rest r2' subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do ty1 =?= ty2 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 85d0d60..7ca3e5d 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -19,10 +19,10 @@ module Language.PureScript.Types where import Data.Data import Data.List (nub) -import Data.Generics (everything, mkT, mkQ, everywhereBut) +import Data.Generics (everything, mkQ) import Control.Monad.Unify -import Control.Arrow ((***)) +import Control.Arrow (second) import Language.PureScript.Names @@ -66,7 +66,7 @@ data Type -- | -- A type with a set of type class constraints -- - | ConstrainedType [(Qualified ProperName, Type)] Type + | ConstrainedType [(Qualified ProperName, [Type])] Type -- | -- A skolem constant -- @@ -122,7 +122,7 @@ tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) -- Smart constructor for function types -- function :: Type -> Type -> Type -function t1 t2 = TypeApp (TypeApp tyFunction t1) t2 +function t1 = TypeApp (TypeApp tyFunction t1) -- | -- Convert a row to a list of pairs of labels and types @@ -143,8 +143,8 @@ rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r)) -- Check whether a type is a monotype -- isMonoType :: Type -> Bool -isMonoType (ForAll _ _ _) = False -isMonoType ty = True +isMonoType ForAll{} = False +isMonoType _ = True -- | -- Universally quantify a type @@ -168,17 +168,17 @@ replaceTypeVars = replaceTypeVars' [] where go :: [String] -> Type -> Type go bs (Object r) = Object $ go bs r - go bs (TypeVar v) | v == name = replacement + go _ (TypeVar v) | v == name = replacement go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2) - go bs (SaturatedTypeSynonym name ts) = SaturatedTypeSynonym name $ map (go bs) ts + go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts go bs f@(ForAll v t sco) | v == name = f | v `elem` usedTypeVariables replacement = let v' = genName v (name : bs ++ usedTypeVariables replacement) t' = replaceTypeVars' bs v (TypeVar v') t in ForAll v' (go (v' : bs) t') sco | otherwise = ForAll v (go (v : bs) t) sco - go bs (ConstrainedType cs t) = ConstrainedType (map (id *** go bs) cs) (go bs t) - go bs (RCons name t r) = RCons name (go bs t) (go bs r) + go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t) + go bs (RCons name' t r) = RCons name' (go bs t) (go bs r) go _ ty = ty genName orig inUse = try 0 where @@ -186,6 +186,12 @@ replaceTypeVars = replaceTypeVars' [] | otherwise = orig ++ show n -- | +-- Replace named type variables with types +-- +replaceAllTypeVars :: [(String, Type)] -> Type -> Type +replaceAllTypeVars = foldl (\f (name, ty) -> replaceTypeVars name ty . f) id + +-- | -- Collect all type variables appearing in a type -- usedTypeVariables :: Type -> [String] @@ -206,7 +212,7 @@ freeTypeVariables = nub . go [] go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2 go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts go bound (ForAll v t _) = go (v : bound) t - go bound (ConstrainedType cs t) = concatMap (go bound . snd) cs ++ go bound t + go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t go bound (RCons _ t r) = go bound t ++ go bound r go _ _ = [] diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs index 9873c68..3add094 100644 --- a/src/Language/PureScript/Values.hs +++ b/src/Language/PureScript/Values.hs @@ -112,7 +112,7 @@ data Value -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and -- instance type, and the type class dictionaries in scope. -- - | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable) + | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable) -- | -- The type of a type class dictionary @@ -141,13 +141,13 @@ data TypeClassDictionaryInScope -- , tcdClassName :: Qualified ProperName -- | - -- The type to which this type class instance applies + -- The types to which this type class instance applies -- - , tcdInstanceType :: Type + , tcdInstanceTypes :: [Type] -- | -- Type class dependencies which must be satisfied to construct this dictionary -- - , tcdDependencies :: Maybe [(Qualified ProperName, Type)] + , tcdDependencies :: Maybe [(Qualified ProperName, [Type])] -- | -- The type of this dictionary -- diff --git a/tests/Main.hs b/tests/Main.hs index 1411c89..fe06cf0 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -20,7 +20,6 @@ import qualified Language.PureScript as P import Data.List (isSuffixOf) import Data.Traversable (traverse) -import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import System.Exit @@ -31,7 +30,6 @@ import System.Environment (getArgs) import Text.Parsec (ParseError) import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U -import qualified Data.Map as M preludeFilename :: IO FilePath preludeFilename = Paths.getDataFileName "prelude/prelude.purs" @@ -45,13 +43,13 @@ compile :: P.Options -> [FilePath] -> IO (Either String String) compile opts inputFiles = do modules <- readInput inputFiles case modules of - Left parseError -> do + Left parseError -> return (Left $ show parseError) - Right ms -> do + Right ms -> case P.compile opts ms of - Left typeError -> do + Left typeError -> return (Left typeError) - Right (js, _, _) -> do + Right (js, _, _) -> return (Right js) assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO () @@ -93,7 +91,7 @@ assertDoesNotCompile inputFile = do main :: IO () main = do cd <- getCurrentDirectory - putStrLn $ cd + putStrLn cd let examples = cd ++ pathSeparator : "examples" let passing = examples ++ pathSeparator : "passing" passingTestCases <- getDirectoryContents passing |