From ce534e93c9b8ca5318d48b274a455af79fe594ed Mon Sep 17 00:00:00 2001 From: PhilFreeman <> Date: Sat, 21 Feb 2015 03:18:00 +0100 Subject: version 0.6.8 diff --git a/examples/passing/OneConstructor.purs b/examples/passing/OneConstructor.purs index 914255a..e46cf6a 100644 --- a/examples/passing/OneConstructor.purs +++ b/examples/passing/OneConstructor.purs @@ -2,6 +2,6 @@ module Main where data One a = One a -one (One a) = a +one' (One a) = a main = Debug.Trace.trace "Done" diff --git a/examples/passing/Rank2Data.purs b/examples/passing/Rank2Data.purs index fb030b0..ccc60f5 100644 --- a/examples/passing/Rank2Data.purs +++ b/examples/passing/Rank2Data.purs @@ -12,18 +12,18 @@ module Main where runNat = \nat -> case nat of Nat f -> f 0 (\n -> n + 1) - zero = Nat (\zero _ -> zero) + zero' = Nat (\zero' _ -> zero') succ = \n -> case n of - Nat f -> Nat (\zero succ -> succ (f zero succ)) + Nat f -> Nat (\zero' succ -> succ (f zero' succ)) add = \n m -> case n of Nat f -> case m of - Nat g -> Nat (\zero succ -> g (f zero succ) succ) + Nat g -> Nat (\zero' succ -> g (f zero' succ) succ) - one = succ zero - two = succ zero + one' = succ zero' + two = succ zero' four = add two two fourNumber = runNat four - main = Debug.Trace.trace "Done" + main = Debug.Trace.trace "Done'" diff --git a/examples/passing/ShadowedTCO.purs b/examples/passing/ShadowedTCO.purs index 6cc4ff9..05d6120 100644 --- a/examples/passing/ShadowedTCO.purs +++ b/examples/passing/ShadowedTCO.purs @@ -2,14 +2,14 @@ module Main where runNat f = f 0 (\n -> n + 1) -zero z _ = z +zero' z _ = z -succ f zero succ = succ (f zero succ) +succ f zero' succ = succ (f zero' succ) -add f g zero succ = g (f zero succ) succ +add f g zero' succ = g (f zero' succ) succ -one = succ zero -two = succ one +one' = succ zero' +two = succ one' four = add two two fourNumber = runNat four diff --git a/prelude/prelude.purs b/prelude/prelude.purs index 1ec9679..ceb99e0 100644 --- a/prelude/prelude.purs +++ b/prelude/prelude.purs @@ -13,8 +13,13 @@ module Prelude , Applicative, pure, liftA1 , Bind, (>>=) , Monad, return, liftM1, ap - , Num, (+), (-), (*), (/), (%) + , Semiring, (+), zero, (*), one + , ModuloSemiring, (/), mod + , Ring, (-) + , (%) , negate + , DivisionRing + , Num , Eq, (==), (/=), refEq, refIneq , Ord, Ordering(..), compare, (<), (>), (<=), (>=) , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement @@ -24,28 +29,28 @@ module Prelude , Unit(..), unit ) where - -- | An alias for `true`, which can be useful in guard clauses: - -- | + -- | An alias for `true`, which can be useful in guard clauses: + -- | -- | E.g. - -- | - -- | max x y | x >= y = x + -- | + -- | max x y | x >= y = x -- | | otherwise = y otherwise :: Boolean otherwise = true - -- | Flips the order of the arguments to a function of two arguments. + -- | Flips the order of the arguments to a function of two arguments. flip :: forall a b c. (a -> b -> c) -> b -> a -> c flip f b a = f a b - -- | Returns its first argument and ignores its second. + -- | Returns its first argument and ignores its second. const :: forall a b. a -> b -> a const a _ = a -- | This function returns its first argument, and can be used to assert type equalities. - -- | This can be useful when types are otherwise ambiguous. - -- | + -- | This can be useful when types are otherwise ambiguous. + -- | -- | E.g. - -- | + -- | -- | main = print $ [] `asTypeOf` [0] -- | -- | If instead, we had written `main = print []`, the type of the argument `[]` would have @@ -205,13 +210,32 @@ module Prelude infixl 6 - infixl 6 + - class Num a where - (+) :: a -> a -> a - (-) :: a -> a -> a - (*) :: a -> a -> a + -- | Addition and multiplication + class Semiring a where + (+) :: a -> a -> a + zero :: a + (*) :: a -> a -> a + one :: a + + -- | Semiring with modulo operation and division where + -- | ```a / b * b + (a `mod` b) = a``` + class (Semiring a) <= ModuloSemiring a where (/) :: a -> a -> a - (%) :: a -> a -> a - negate :: a -> a + mod :: a -> a -> a + + -- | Addition, multiplication, and subtraction + class (Semiring a) <= Ring a where + (-) :: a -> a -> a + + negate :: forall a. (Ring a) => a -> a + negate a = zero - a + + -- | Ring where every nonzero element has a multiplicative inverse (possibly + -- | a non-commutative field) so that ```a `mod` b = zero``` + class (Ring a, ModuloSemiring a) <= DivisionRing a + + -- | A commutative field + class (DivisionRing a) <= Num a foreign import numAdd """ @@ -258,20 +282,24 @@ module Prelude } """ :: Number -> Number -> Number - foreign import numNegate - """ - function numNegate(n) { - return -n; - } - """ :: Number -> Number + (%) = numMod - instance numNumber :: Num Number where + instance semiringNumber :: Semiring Number where (+) = numAdd - (-) = numSub + zero = 0 (*) = numMul + one = 1 + + instance ringNumber :: Ring Number where + (-) = numSub + + instance moduloSemiringNumber :: ModuloSemiring Number where (/) = numDiv - (%) = numMod - negate = numNegate + mod _ _ = 0 + + instance divisionRingNumber :: DivisionRing Number + + instance numNumber :: Num Number newtype Unit = Unit {} diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 6ca4ec5..41113f2 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -18,7 +18,6 @@ import Control.Applicative import Control.Monad import Control.Monad.Writer import Control.Arrow (first) -import Data.Function (on) import Data.List import Data.Maybe (fromMaybe) import Data.Version (showVersion) @@ -32,19 +31,18 @@ import System.Exit (exitSuccess, exitFailure) import System.IO (hPutStrLn, stderr) data PSCDocsOptions = PSCDocsOptions - { pscdIncludeHeir :: Bool - , pscdInputFiles :: [FilePath] + { pscdInputFiles :: [FilePath] } docgen :: PSCDocsOptions -> IO () -docgen (PSCDocsOptions showHierarchy input) = do +docgen (PSCDocsOptions input) = do e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input) case e of Left err -> do hPutStrLn stderr $ show err exitFailure Right ms -> do - putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms) + putStrLn . runDocs $ renderModules (map snd ms) exitSuccess parseFile :: FilePath -> IO (FilePath, String) @@ -69,55 +67,38 @@ atIndent indent text = let ls = lines text in withIndent indent (tell ls) +fenced :: String -> Docs +fenced text = fencedBlock (tell $ lines text) + +fencedBlock :: Docs -> Docs +fencedBlock inner = do + tell ["``` purescript"] + inner + tell ["```"] + ticks :: String -> String ticks = ("`" ++) . (++ "`") -renderModules :: Bool -> [P.Module] -> Docs -renderModules showHierarchy ms = do +renderModules :: [P.Module] -> Docs +renderModules ms = do headerLevel 1 "Module Documentation" spacer - mapM_ (renderModule showHierarchy) ms - -renderModule :: Bool -> P.Module -> Docs -renderModule showHierarchy mdl@(P.Module moduleName _ exps) = - let ds = P.exportedDeclarations mdl - hasTypes = any isTypeDeclaration ds - hasTypeclasses = any isTypeClassDeclaration ds - hasTypeclassInstances = any isTypeInstanceDeclaration ds - hasValues = any isValueDeclaration ds - in do + mapM_ renderModule ms + +renderModule :: P.Module -> Docs +renderModule mdl@(P.Module moduleName _ exps) = do headerLevel 2 $ "Module " ++ P.runModuleName moduleName spacer - when hasTypes $ do - headerLevel 3 "Types" - spacer - renderTopLevel exps (filter isTypeDeclaration ds) - spacer - when hasTypeclasses $ do - headerLevel 3 "Type Classes" - spacer - when showHierarchy $ do - renderTypeclassImage moduleName - spacer - renderTopLevel exps (filter isTypeClassDeclaration ds) - spacer - when hasTypeclassInstances $ do - headerLevel 3 "Type Class Instances" - spacer - renderTopLevel exps (filter isTypeInstanceDeclaration ds) - spacer - when hasValues $ do - headerLevel 3 "Values" - spacer - renderTopLevel exps (filter isValueDeclaration ds) - spacer + renderTopLevel exps (P.exportedDeclarations mdl) + spacer renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs -renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do - traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl) - spacer - renderDeclaration exps decl - spacer +renderTopLevel exps decls = forM_ decls $ \decl -> + when (canRenderDecl decl) $ do + traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl) + spacer + renderDeclaration exps decl + spacer renderTypeclassImage :: P.ModuleName -> Docs renderTypeclassImage name = @@ -137,63 +118,62 @@ getDeclarationTitle _ = Nothing renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs renderDeclaration _ (P.TypeDeclaration ident ty) = - atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty + fenced $ show ident ++ " :: " ++ prettyPrintType' ty renderDeclaration _ (P.ExternDeclaration _ ident _ ty) = - atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty + fenced $ show ident ++ " :: " ++ prettyPrintType' ty renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do let typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args) typeName = prettyPrintType' typeApp exported = filter (P.isDctorExported name exps . fst) ctors - atIndent 4 $ show dtype ++ " " ++ typeName - zipWithM_ (\isFirst (ctor, tys) -> - atIndent 6 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)) - (True : repeat False) exported + fencedBlock $ do + tell [show dtype ++ " " ++ typeName] + zipWithM_ (\isFirst (ctor, tys) -> + atIndent 2 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)) + (True : repeat False) exported renderDeclaration _ (P.ExternDataDeclaration name kind) = - atIndent 4 $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind + fenced $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do let typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args) typeName = prettyPrintType' typeApp - atIndent 4 $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty + fenced $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do let impliesText = case implies of [] -> "" is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= " classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args) className = prettyPrintType' classApp - atIndent 4 $ "class " ++ impliesText ++ className ++ " where" - mapM_ renderClassMember ds + fencedBlock $ do + tell ["class " ++ impliesText ++ className ++ " where"] + mapM_ renderClassMember ds where renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d - renderClassMember (P.TypeDeclaration ident ty) = atIndent 6 $ show ident ++ " :: " ++ prettyPrintType' ty + renderClassMember (P.TypeDeclaration ident ty) = atIndent 2 $ show ident ++ " :: " ++ prettyPrintType' ty renderClassMember _ = error "Invalid argument to renderClassMember." renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do let constraintsText = case constraints of [] -> "" cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => " - atIndent 4 $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys) + fenced $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys) renderDeclaration exps (P.PositionedDeclaration _ com d) = do - renderComments com renderDeclaration exps d + renderComments com renderDeclaration _ _ = return () renderComments :: [P.Comment] -> Docs renderComments cs = do let raw = concatMap toLines cs - - if all hasPipe raw - then atIndent 0 . unlines . map stripPipes $ raw - else atIndent 4 $ unlines raw - - unless (null raw) spacer + when (all hasPipe raw) $ do + spacer + atIndent 0 . unlines . map stripPipes $ raw where toLines (P.LineComment s) = [s] toLines (P.BlockComment s) = lines s - + hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False } - + stripPipes = dropPipe . dropWhile (== ' ') dropPipe ('|':' ':s) = s @@ -223,42 +203,24 @@ getName (P.TypeInstanceDeclaration name _ _ _ _) = show name getName (P.PositionedDeclaration _ _ d) = getName d getName _ = error "Invalid argument to getName" -isValueDeclaration :: P.Declaration -> Bool -isValueDeclaration P.TypeDeclaration{} = True -isValueDeclaration P.ExternDeclaration{} = True -isValueDeclaration (P.PositionedDeclaration _ _ d) = isValueDeclaration d -isValueDeclaration _ = False - -isTypeDeclaration :: P.Declaration -> Bool -isTypeDeclaration P.DataDeclaration{} = True -isTypeDeclaration P.ExternDataDeclaration{} = True -isTypeDeclaration P.TypeSynonymDeclaration{} = True -isTypeDeclaration (P.PositionedDeclaration _ _ d) = isTypeDeclaration d -isTypeDeclaration _ = False - -isTypeClassDeclaration :: P.Declaration -> Bool -isTypeClassDeclaration P.TypeClassDeclaration{} = True -isTypeClassDeclaration (P.PositionedDeclaration _ _ d) = isTypeClassDeclaration d -isTypeClassDeclaration _ = False - -isTypeInstanceDeclaration :: P.Declaration -> Bool -isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True -isTypeInstanceDeclaration (P.PositionedDeclaration _ _ d) = isTypeInstanceDeclaration d -isTypeInstanceDeclaration _ = False +canRenderDecl :: P.Declaration -> Bool +canRenderDecl P.TypeDeclaration{} = True +canRenderDecl P.ExternDeclaration{} = True +canRenderDecl P.DataDeclaration{} = True +canRenderDecl P.ExternDataDeclaration{} = True +canRenderDecl P.TypeSynonymDeclaration{} = True +canRenderDecl P.TypeClassDeclaration{} = True +canRenderDecl P.TypeInstanceDeclaration{} = True +canRenderDecl (P.PositionedDeclaration _ _ d) = canRenderDecl d +canRenderDecl _ = False inputFile :: Parser FilePath inputFile = strArgument $ metavar "FILE" <> help "The input .purs file(s)" -includeHeirarcy :: Parser Bool -includeHeirarcy = switch $ - long "hierarchy-images" - <> help "Include markdown for type class hierarchy images in the output." - pscDocsOptions :: Parser PSCDocsOptions -pscDocsOptions = PSCDocsOptions <$> includeHeirarcy - <*> many inputFile +pscDocsOptions = PSCDocsOptions <$> many inputFile main :: IO () main = execParser opts >>= docgen diff --git a/psc-make/Main.hs b/psc-make/Main.hs index fcad3fb..2bf5ced 100644 --- a/psc-make/Main.hs +++ b/psc-make/Main.hs @@ -17,9 +17,11 @@ module Main where import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except +import Control.Monad.Reader import Data.Version (showVersion) +import Data.Traversable (traverse) import Options.Applicative as Opts @@ -50,20 +52,19 @@ readInput InputOptions{..} = do content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content) -newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String) +newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a } + deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make)) -runMake :: Make a -> IO (Either String a) -runMake = runErrorT . unMake +runMake :: P.Options P.Make -> Make a -> IO (Either String a) +runMake opts = runExceptT . flip runReaderT opts . unMake makeIO :: IO a -> Make a -makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError +makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError instance P.MonadMake Make where getTimestamp path = makeIO $ do exists <- doesFileExist path - case exists of - True -> Just <$> getModificationTime path - False -> return Nothing + traverse (const $ getModificationTime path) $ guard exists readTextFile path = makeIO $ do putStrLn $ "Reading " ++ path readFile path @@ -71,7 +72,6 @@ instance P.MonadMake Make where mkdirp path putStrLn $ "Writing " ++ path writeFile path text - liftError = either throwError return progress = makeIO . putStrLn compile :: PSCMakeOptions -> IO () @@ -82,7 +82,7 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do print err exitFailure Right ms -> do - e <- runMake $ P.make outputDir opts ms prefix + e <- runMake opts $ P.make outputDir ms prefix case e of Left err -> do putStrLn err @@ -130,6 +130,12 @@ noOpts = switch $ long "no-opts" <> help "Skip the optimization phase." +comments :: Parser Bool +comments = switch $ + short 'c' + <> long "comments" + <> help "Include comments in the generated code." + verboseErrors :: Parser Bool verboseErrors = switch $ short 'v' @@ -149,6 +155,7 @@ options = P.Options <$> noPrelude <*> noMagicDo <*> pure Nothing <*> noOpts + <*> comments <*> verboseErrors <*> pure P.MakeOptions diff --git a/psc/Main.hs b/psc/Main.hs index df1db1f..25709a1 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -17,7 +17,8 @@ module Main where import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except +import Control.Monad.Reader import Data.Maybe (fromMaybe) import Data.Version (showVersion) @@ -61,7 +62,7 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do hPutStrLn stderr $ show err exitFailure Right ms -> do - case P.compile opts (map snd ms) prefix of + case P.compile (map snd ms) prefix `runReaderT` opts of Left err -> do hPutStrLn stderr err exitFailure @@ -137,6 +138,12 @@ noPrelude = switch $ long "no-prelude" <> help "Omit the Prelude" +comments :: Parser Bool +comments = switch $ + short 'c' + <> long "comments" + <> help "Include comments in the generated code." + useStdIn :: Parser Bool useStdIn = switch $ short 's' @@ -173,6 +180,7 @@ options = P.Options <$> noPrelude <*> runMain <*> noOpts <*> verboseErrors + <*> comments <*> additionalOptions where additionalOptions = diff --git a/psci/Main.hs b/psci/Main.hs index 73aa302..2b8bc82 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -13,7 +13,11 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds, DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} module Main where @@ -27,8 +31,8 @@ import qualified Data.Map as M import Control.Applicative import Control.Monad -import Control.Monad.Error (ErrorT(..), MonadError) -import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Except (ExceptT(..), MonadError, runExceptT) +import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.State.Strict @@ -53,9 +57,8 @@ import qualified Paths_purescript as Paths import Commands as C import Parser - data PSCiOptions = PSCiOptions - { psciSingleLineFlag :: Bool + { psciMultiLineMode :: Bool , psciInputFile :: [FilePath] } @@ -96,7 +99,7 @@ updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modu -- Updates the state to have more let bindings. -- updateLets :: [P.Declaration] -> PSCiState -> PSCiState -updateLets ds st = st { psciLetBindings = ds ++ psciLetBindings st } +updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds } -- File helpers -- | @@ -150,7 +153,7 @@ loadAllImportedModules = do modulesOrFirstError <- psciIO $ loadAllModules files case modulesOrFirstError of Left err -> psciIO $ print err - Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules } + Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules } -- | -- Expands tilde in path. @@ -182,8 +185,6 @@ prologueMessage = intercalate "\n" , " |_| " , "" , ":? shows help" - , "" - , "Expressions are terminated using Ctrl+D" ] -- | @@ -314,7 +315,7 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions -- | Compilation options. -- options :: P.Options P.Make -options = P.Options False False False Nothing False False P.MakeOptions +options = P.Options False False False Nothing False False False P.MakeOptions -- | -- PSCI monad @@ -322,27 +323,25 @@ options = P.Options False False False Nothing False False P.MakeOptions newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad) psciIO :: IO a -> PSCI a -psciIO io = PSCI (lift (lift io)) +psciIO io = PSCI . lift $ lift io -newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadError String) +newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a } + deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make)) runMake :: Make a -> IO (Either String a) -runMake = runErrorT . unMake +runMake = runExceptT . flip runReaderT options . unMake makeIO :: IO a -> Make a -makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError +makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError instance P.MonadMake Make where getTimestamp path = makeIO $ do exists <- doesFileExist path - if exists - then Just <$> getModificationTime path - else return Nothing + traverse (const $ getModificationTime path) $ guard exists readTextFile path = makeIO $ readFile path writeTextFile path text = makeIO $ do mkdirp path writeFile path text - liftError = either throwError return progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s mkdirp :: FilePath -> IO () @@ -402,7 +401,7 @@ handleDeclaration :: P.Expr -> PSCI () handleDeclaration val = do st <- PSCI $ lift get let m = createTemporaryModule True st val - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] + e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] case e of Left err -> PSCI $ outputStrLn err Right _ -> do @@ -423,7 +422,7 @@ handleLet ds = do st <- PSCI $ lift get let st' = updateLets ds st let m = createTemporaryModule False st' (P.ObjectLiteral []) - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) [] + e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) [] case e of Left err -> PSCI $ outputStrLn err Right _ -> PSCI $ lift (put st') @@ -456,7 +455,7 @@ handleImport :: P.ModuleName -> PSCI () handleImport moduleName = do st <- updateImports moduleName <$> PSCI (lift get) let m = createTemporaryModuleForImports st - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] + e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] case e of Left err -> PSCI $ outputStrLn err Right _ -> do @@ -470,7 +469,7 @@ handleTypeOf :: P.Expr -> PSCI () handleTypeOf val = do st <- PSCI $ lift get let m = createTemporaryModule False st val - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] + e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] case e of Left err -> PSCI $ outputStrLn err Right env' -> @@ -504,7 +503,7 @@ handleBrowse :: P.ModuleName -> PSCI () handleBrowse moduleName = do st <- PSCI $ lift get let loadedModules = psciLoadedModules st - env <- psciIO . runMake $ P.make modulesDir options loadedModules [] + env <- psciIO . runMake $ P.make modulesDir loadedModules [] case env of Left err -> PSCI $ outputStrLn err Right env' -> @@ -520,7 +519,7 @@ handleKindOf typ = do st <- PSCI $ lift get let m = createTemporaryModuleForKind st typ mName = P.ModuleName [P.ProperName "$PSCI"] - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] + e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) [] case e of Left err -> PSCI $ outputStrLn err Right env' -> @@ -571,7 +570,7 @@ handleCommand (LoadFile filePath) = do PSCI . outputStrLn $ "Couldn't locate: " ++ filePath handleCommand Reset = do files <- psciImportedFilenames <$> PSCI (lift get) - PSCI . lift . modify $ \st -> st + PSCI . lift . modify $ \st -> st { psciImportedFilenames = files , psciImportedModuleNames = defaultImports , psciLetBindings = [] @@ -601,32 +600,33 @@ loadUserConfig = do -- The PSCI main loop. -- loop :: PSCiOptions -> IO () -loop (PSCiOptions singleLineMode files) = do +loop PSCiOptions{..} = do config <- loadUserConfig - modulesOrFirstError <- loadAllModules files + modulesOrFirstError <- loadAllModules psciInputFile case modulesOrFirstError of Left err -> print err >> exitFailure Right modules -> do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } - flip evalStateT (PSCiState files defaultImports modules []) . runInputT (setComplete completion settings) $ do + flip evalStateT (PSCiState psciInputFile defaultImports modules []) . runInputT (setComplete completion settings) $ do outputStrLn prologueMessage traverse_ (mapM_ (runPSCI . handleCommand)) config go where go :: InputT (StateT PSCiState IO) () go = do - c <- getCommand singleLineMode + c <- getCommand (not psciMultiLineMode) case c of Left err -> outputStrLn err >> go Right Nothing -> go Right (Just Quit) -> outputStrLn quitMessage Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go -singleLineFlag :: Parser Bool -singleLineFlag = switch $ - long "single-line-mode" - <> Opts.help "Run in single-line mode" +multiLineMode :: Parser Bool +multiLineMode = switch $ + long "multi-line-mode" + <> short 'm' + <> Opts.help "Run in multi-line mode (use ^D to terminate commands)" inputFile :: Parser FilePath inputFile = strArgument $ @@ -634,7 +634,7 @@ inputFile = strArgument $ <> Opts.help "Optional .purs files to load on start" psciOptions :: Parser PSCiOptions -psciOptions = PSCiOptions <$> singleLineFlag +psciOptions = PSCiOptions <$> multiLineMode <*> many inputFile main :: IO () diff --git a/purescript.cabal b/purescript.cabal index e23d58d..223e9b3 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.6.7.1 +version: 0.6.8 cabal-version: >=1.8 build-type: Simple license: MIT @@ -31,10 +31,9 @@ library filepath -any, mtl >= 2.1.0 && < 2.3.0, parsec -any, - transformers >= 0.3 && < 0.5, + transformers >= 0.4.0 && < 0.5, utf8-string >= 1 && < 2, pattern-arrows >= 0.0.2 && < 0.1, - monad-unify >= 0.2.2 && < 0.3, file-embed >= 0.0.7 && < 0.0.8, time -any exposed-modules: Language.PureScript @@ -111,11 +110,13 @@ library Language.PureScript.TypeChecker.Unify Language.PureScript.TypeClassDictionaries Language.PureScript.Types + + Control.Monad.Unify exposed: True buildable: True hs-source-dirs: src other-modules: Paths_purescript - ghc-options: -Wall -fno-warn-warnings-deprecations -O2 + ghc-options: -Wall -O2 executable psc build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, @@ -125,7 +126,7 @@ executable psc buildable: True hs-source-dirs: psc other-modules: - ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind + ghc-options: -Wall -O2 -fno-warn-unused-do-bind executable psc-make build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, @@ -135,7 +136,7 @@ executable psc-make buildable: True hs-source-dirs: psc-make other-modules: - ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind + ghc-options: -Wall -O2 -fno-warn-unused-do-bind executable psci build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, @@ -148,7 +149,7 @@ executable psci hs-source-dirs: psci other-modules: Commands Parser - ghc-options: -Wall -fno-warn-warnings-deprecations -O2 + ghc-options: -Wall -O2 executable psc-docs build-depends: base >=4 && <5, purescript -any, @@ -157,7 +158,7 @@ executable psc-docs buildable: True hs-source-dirs: psc-docs other-modules: - ghc-options: -Wall -fno-warn-warnings-deprecations -O2 + ghc-options: -Wall -O2 executable psc-hierarchy build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0, @@ -166,7 +167,7 @@ executable psc-hierarchy buildable: True hs-source-dirs: hierarchy other-modules: - ghc-options: -Wall -fno-warn-warnings-deprecations -O2 + ghc-options: -Wall -O2 test-suite tests build-depends: base >=4 && <5, containers -any, directory -any, diff --git a/src/Control/Monad/Unify.hs b/src/Control/Monad/Unify.hs new file mode 100644 index 0000000..4fe55e9 --- /dev/null +++ b/src/Control/Monad/Unify.hs @@ -0,0 +1,155 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Unify +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Control.Monad.Unify where + +import Data.String (IsString) +import Data.Monoid + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Error.Class + +import Data.HashMap.Strict as M + +-- | +-- Untyped unification variables +-- +type Unknown = Int + +-- | +-- A type which can contain unification variables +-- +class Partial t where + unknown :: Unknown -> t + isUnknown :: t -> Maybe Unknown + unknowns :: t -> [Unknown] + ($?) :: Substitution t -> t -> t + +-- | +-- Identifies types which support unification +-- +class (Partial t) => Unifiable m t | t -> m where + (=?=) :: t -> t -> UnifyT t m () + +-- | +-- A substitution maintains a mapping from unification variables to their values +-- +data Substitution t = Substitution { runSubstitution :: M.HashMap Int t } + +instance (Partial t) => Monoid (Substitution t) where + mempty = Substitution M.empty + s1 `mappend` s2 = Substitution $ + M.map (s2 $?) (runSubstitution s1) `M.union` + M.map (s1 $?) (runSubstitution s2) + +-- | +-- State required for type checking +-- +data UnifyState t = UnifyState { + -- | + -- The next fresh unification variable + -- + unifyNextVar :: Int + -- | + -- The current substitution + -- + , unifyCurrentSubstitution :: Substitution t + } + +-- | +-- An empty @UnifyState@ +-- +defaultUnifyState :: (Partial t) => UnifyState t +defaultUnifyState = UnifyState 0 mempty + +-- | +-- The type checking monad, which provides the state of the type checker, and error reporting capabilities +-- +newtype UnifyT t m a = UnifyT { unUnify :: (StateT (UnifyState t) m) a } + deriving (Functor, Monad, Applicative, Alternative, MonadPlus) + +instance (MonadState s m) => MonadState s (UnifyT t m) where + get = UnifyT . lift $ get + put = UnifyT . lift . put + +instance (MonadError e m) => MonadError e (UnifyT t m) where + throwError = UnifyT . throwError + catchError e f = UnifyT $ catchError (unUnify e) (unUnify . f) + +-- | +-- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable +-- +runUnify :: UnifyState t -> UnifyT t m a -> m (a, UnifyState t) +runUnify s = flip runStateT s . unUnify + +-- | +-- Substitute a single unification variable +-- +substituteOne :: (Partial t) => Unknown -> t -> Substitution t +substituteOne u t = Substitution $ M.singleton u t + +-- | +-- Replace a unification variable with the specified value in the current substitution +-- +(=:=) :: (IsString e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m () +(=:=) u t' = do + st <- UnifyT get + let sub = unifyCurrentSubstitution st + let t = sub $? t' + occursCheck u t + let current = sub $? unknown u + case isUnknown current of + Just u1 | u1 == u -> return () + _ -> current =?= t + UnifyT $ modify $ \s -> s { unifyCurrentSubstitution = substituteOne u t <> unifyCurrentSubstitution s } + +-- | +-- Perform the occurs check, to make sure a unification variable does not occur inside a value +-- +occursCheck :: (IsString e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m () +occursCheck u t = + case isUnknown t of + Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ "Occurs check fails" + _ -> return () + +-- | +-- Generate a fresh untyped unification variable +-- +fresh' :: (Monad m) => UnifyT t m Unknown +fresh' = do + st <- UnifyT get + UnifyT $ modify $ \s -> s { unifyNextVar = succ (unifyNextVar s) } + return $ unifyNextVar st + +-- | +-- Generate a fresh unification variable at a specific type +-- +fresh :: (Monad m, Partial t) => UnifyT t m t +fresh = do + u <- fresh' + return $ unknown u + + + diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 16f2189..a1a5ef7 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell, FlexibleContexts #-} module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where @@ -22,13 +22,15 @@ import Data.Function (on) import Data.List (sortBy, groupBy, intercalate) import Data.Maybe (fromMaybe) import Data.Time.Clock +import qualified Data.Traversable as T (traverse) import qualified Data.ByteString.UTF8 as BU import qualified Data.Map as M import qualified Data.Set as S import Control.Applicative import Control.Arrow ((&&&)) -import Control.Monad.Error +import Control.Monad.Except +import Control.Monad.Reader import System.FilePath (()) @@ -71,42 +73,47 @@ import qualified Language.PureScript.Constants as C -- -- * Pretty-print the generated Javascript -- -compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment) +compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m) + => [Module] -> [String] -> m (String, String, Environment) compile = compile' initEnvironment -compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment) -compile' env opts ms prefix = do - (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms +compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m) + => Environment -> [Module] -> [String] -> m (String, String, Environment) +compile' env ms prefix = do + noPrelude <- asks optionsNoPrelude + additional <- asks optionsAdditional + mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain) + (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted - (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent + (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated let corefn = map (CoreFn.moduleToCoreFn env') regrouped - let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts) + let entryPoints = moduleNameFromString `map` entryPointModules additional let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn let renamed = renameInModules elim - let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts) + let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed - let js = evalSupply nextVar $ concat <$> mapM (moduleToJs opts) modulesToCodeGen + js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen) let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped - js' <- generateMain env' opts js + js' <- generateMain env' js let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js'] return (pjs, exts, env') - where - mainModuleIdent = moduleNameFromString <$> optionsMain opts -generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS] -generateMain env opts js = - case moduleNameFromString <$> optionsMain opts of +generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS] +generateMain env js = do + main <- asks optionsMain + additional <- asks optionsAdditional + case moduleNameFromString <$> main of Just mmi -> do when ((mmi, Ident C.main) `M.notMember` names env) $ - Left $ show mmi ++ "." ++ C.main ++ " is undefined" - return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []] + throwError $ show mmi ++ "." ++ C.main ++ " is undefined" + return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []] _ -> return js -- | -- A type class which collects the IO actions we need to be able to run in "make" mode -- -class MonadMake m where +class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where -- | -- Get a file timestamp -- @@ -123,11 +130,6 @@ class MonadMake m where writeTextFile :: FilePath -> String -> m () -- | - -- Report an error - -- - liftError :: Either String a -> m a - - -- | -- Respond to a progress update -- progress :: String -> m () @@ -152,11 +154,13 @@ traverseEither f (Right y) = Right <$> f y -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again. -- -make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment -make outputDir opts ms prefix = do +make :: (Functor m, Applicative m, Monad m, MonadMake m) + => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment +make outputDir ms prefix = do + noPrelude <- asks optionsNoPrelude let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms) - (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else map (importPrelude . snd) ms + (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms toRebuild <- foldM (\s (Module moduleName' _ _) -> do let filePath = runModuleName moduleName' @@ -176,15 +180,16 @@ make outputDir opts ms prefix = do marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted - (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked) + (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked) - evalSupplyT nextVar (go initEnvironment desugared) + evalSupplyT nextVar $ go initEnvironment desugared where - go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment + go :: (Functor m, Applicative m, Monad m, MonadMake m) + => Environment -> [(Bool, Module)] -> SupplyT m Environment go env [] = return env go env ((False, m) : ms') = do - (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m + (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m go env' ms' go env ((True, m@(Module moduleName' _ exps)) : ms') = do @@ -194,15 +199,15 @@ make outputDir opts ms prefix = do lift . progress $ "Compiling " ++ runModuleName moduleName' - (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m + (Module _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m - regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated + regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated let mod' = Module moduleName' regrouped exps let corefn = CoreFn.moduleToCoreFn env' mod' let [renamed] = renameInModules [corefn] - pjs <- prettyPrintJS <$> moduleToJs opts renamed + pjs <- prettyPrintJS <$> moduleToJs renamed let js = unlines $ map ("// " ++) prefix ++ [pjs] let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env'] @@ -220,10 +225,10 @@ make outputDir opts ms prefix = do rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do let externsFile = outputDir runModuleName moduleName' "externs.purs" externs <- readTextFile externsFile - externsModules <- liftError . fmap (map snd) . either (Left . show) Right $ P.parseModulesFromFiles id [(externsFile, externs)] + externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)] case externsModules of [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms' - _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid" + _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid" reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName] reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ] diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 9ed3f88..ef097e5 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -398,6 +398,10 @@ data Expr -- | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope] -- | + -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring. + -- + | TypeClassDictionaryAccessor (Qualified ProperName) Ident + -- | -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking -- | SuperClassDictionary (Qualified ProperName) [Type] diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index c5305e4..e677751 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -13,21 +13,22 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GADTs, ViewPatterns #-} +{-# LANGUAGE GADTs, ViewPatterns, FlexibleContexts #-} module Language.PureScript.CodeGen.JS ( module AST, module Common, - bindToJs, moduleToJs ) where import Data.List ((\\), delete) import Data.Maybe (mapMaybe) +import qualified Data.Traversable as T (traverse) import Control.Applicative import Control.Arrow ((&&&)) import Control.Monad (foldM, replicateM, forM) +import Control.Monad.Reader (MonadReader, asks, lift) import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.CodeGen.JS.Common as Common @@ -43,16 +44,18 @@ import qualified Language.PureScript.Constants as C -- Generate code in the simplified Javascript intermediate representation for all declarations in a -- module. -- -moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module Ann -> SupplyT m [JS] -moduleToJs opts (Module name imps exps foreigns decls) = do - let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps +moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => Module Ann -> SupplyT m [JS] +moduleToJs (Module name imps exps foreigns decls) = do + additional <- lift $ asks optionsAdditional + jsImports <- lift . T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns jsDecls <- mapM (bindToJs name) decls - let optimized = concatMap (map $ optimize opts) jsDecls + optimized <- lift $ T.traverse (T.traverse optimize) jsDecls let isModuleEmpty = null exps - let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized + let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ concat optimized let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps - return $ case optionsAdditional opts of + return $ case additional of MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps'] CompileOptions ns _ _ | not isModuleEmpty -> [ JSVariableIntroduction ns @@ -65,18 +68,19 @@ moduleToJs opts (Module name imps exps foreigns decls) = do -- | -- Generates Javascript code for a module import. -- -importToJs :: Options mode -> ModuleName -> JS -importToJs opts mn = - JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody) - where - moduleBody = case optionsAdditional opts of - MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)] - CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns) +importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS +importToJs mn = do + additional <- asks optionsAdditional + let moduleBody = case additional of + MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)] + CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns) + return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody) -- | -- Generate code in the simplified Javascript intermediate representation for a declaration -- -bindToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Bind Ann -> SupplyT m [JS] +bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => ModuleName -> Bind Ann -> SupplyT m [JS] bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp)) @@ -86,9 +90,13 @@ bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp)) -- -- The main purpose of this function is to handle code generation for comments. -- -nonRecToJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Ident -> Expr Ann -> SupplyT m JS -nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = - JSComment com <$> nonRecToJS m i (modifyAnn removeComments e) +nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => ModuleName -> Ident -> Expr Ann -> SupplyT m JS +nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do + withoutComment <- lift $ asks optionsNoComments + if withoutComment + then nonRecToJS m i (modifyAnn removeComments e) + else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e) nonRecToJS mp ident val = do js <- valueToJs mp val return $ JSVariableIntroduction (identToJs ident) (Just js) @@ -117,10 +125,11 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop) -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. -- -valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS +valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => ModuleName -> Expr Ann -> SupplyT m JS valueToJs m (Literal _ l) = literalToValueJS m l -valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) = +valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) = return $ JSAccessor "value" $ qualifiedToJS m id name valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) = return $ JSAccessor "create" $ qualifiedToJS m id name @@ -128,7 +137,7 @@ valueToJs m (Accessor _ prop val) = accessorString prop <$> valueToJs m val valueToJs m (ObjectUpdate _ o ps) = do obj <- valueToJs m o - sts <- mapM (sndM (valueToJs m)) ps + sts <- mapM (sndM $ valueToJs m) ps extendObj obj sts valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = let args = unAbs e @@ -148,7 +157,7 @@ valueToJs m e@App{} = do args' <- mapM (valueToJs m) args case f of Var (_, _, _, Just IsNewtype) _ -> return (head args') - Var (_, _, _, Just (IsConstructor _ arity)) name | arity == length args -> + Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields -> return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args' Var (_, _, _, Just IsTypeClassConstructor) name -> return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args' @@ -171,30 +180,25 @@ valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = JSObjectLiteral [("create", JSFunction Nothing ["value"] (JSBlock [JSReturn $ JSVar "value"]))]) -valueToJs _ (Constructor _ _ (ProperName ctor) 0) = +valueToJs _ (Constructor _ _ (ProperName ctor) []) = return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock []) , JSAssignment (JSAccessor "value" (JSVar ctor)) (JSUnary JSNew $ JSApp (JSVar ctor) []) ] -valueToJs _ (Constructor _ _ (ProperName ctor) arity) = - return $ iife ctor [ makeConstructor ctor arity - , JSAssignment (JSAccessor "create" (JSVar ctor)) (go ctor 0 arity []) - ] - where - makeConstructor :: String -> Int -> JS - makeConstructor ctorName n = - let args = [ "value" ++ show index | index <- [0..n-1] ] - body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ] - in JSFunction (Just ctorName) args (JSBlock body) - go :: String -> Int -> Int -> [JS] -> JS - go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar pn) (reverse values) - go pn index n values = - JSFunction Nothing ["value" ++ show index] - (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))]) - +valueToJs _ (Constructor _ _ (ProperName ctor) fields) = + let constructor = + let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ] + in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body) + createFn = + let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields) + in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields + in return $ iife ctor [ constructor + , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn + ] iife :: String -> [JS] -> JS iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) [] -literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS +literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => ModuleName -> Literal (Expr Ann) -> SupplyT m JS literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b @@ -241,7 +245,8 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a) -- Generate code in the simplified Javascript intermediate representation for pattern match binders -- and guards. -- -bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS +bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS bindersToJs m binders vals = do valNames <- replicateM (length vals) freshName let assignments = zipWith JSVariableIntroduction valNames (map Just vals) @@ -251,14 +256,16 @@ bindersToJs m binders vals = do return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]]))) [] where - go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS] + go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS] go _ done [] = return done go (v:vs) done' (b:bs) = do done'' <- go vs done' bs binderToJs m v done'' b go _ _ _ = error "Invalid arguments to bindersToJs" - guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS] + guardsToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS] guardsToJs (Left gs) = forM gs $ \(cond, val) -> do cond' <- valueToJs m cond done <- valueToJs m val @@ -269,7 +276,8 @@ bindersToJs m binders vals = do -- Generate code in the simplified Javascript intermediate representation for a pattern match -- binder. -- -binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS] +binderToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS] binderToJs _ _ done (NullBinder{}) = return done binderToJs m varName done (LiteralBinder _ l) = literalToBinderJS m varName done l @@ -277,8 +285,8 @@ binderToJs _ varName done (VarBinder _ ident) = return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done) binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) = binderToJs m varName done b -binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType _)) _ ctor bs) = do - js <- go 0 done bs +binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do + js <- go (zip fields bs) done return $ case ctorType of ProductType -> js SumType -> @@ -286,13 +294,14 @@ binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorT (JSBlock js) Nothing] where - go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS] - go _ done' [] = return done' - go index done' (binder:bs') = do + go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS] + go [] done' = return done' + go ((field, binder) : remain) done' = do argVar <- freshName - done'' <- go (index + 1) done' bs' + done'' <- go remain done' js <- binderToJs m argVar done'' binder - return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js) + return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js) binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do let (headBinders, tailBinder) = uncons [] binder numberOfHeadBinders = fromIntegral $ length headBinders @@ -316,7 +325,8 @@ binderToJs m varName done (NamedBinder _ ident binder) = do js <- binderToJs m varName done binder return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js) -literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS] +literalToBinderJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS] literalToBinderJS _ varName done (NumericLiteral num) = return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing] literalToBinderJS _ varName done (StringLiteral str) = @@ -327,7 +337,8 @@ literalToBinderJS _ varName done (BooleanLiteral False) = return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing] literalToBinderJS m varName done (ObjectLiteral bs) = go done bs where - go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS] + go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS] go done' [] = return done' go done' ((prop, binder):bs') = do propVar <- freshName @@ -338,7 +349,8 @@ literalToBinderJS m varName done (ArrayLiteral bs) = do js <- go done 0 bs return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing] where - go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS] + go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m) + => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS] go done' _ [] = return done' go done' index (binder:bs') = do elVar <- freshName diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index 551e179..3906cd5 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -31,10 +31,14 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} + module Language.PureScript.CodeGen.JS.Optimizer ( optimize ) where +import Control.Monad.Reader (MonadReader, ask, asks) + import Language.PureScript.CodeGen.JS.AST import Language.PureScript.Options import qualified Language.PureScript.Constants as C @@ -49,28 +53,34 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks -- | -- Apply a series of optimizer passes to simplified Javascript code -- -optimize :: Options mode -> JS -> JS -optimize opts | optionsNoOptimizations opts = id - | otherwise = untilFixedPoint (applyAll - [ collapseNestedBlocks - , collapseNestedIfs - , tco opts - , magicDo opts - , removeCodeAfterReturnStatements - , removeUnusedArg - , removeUndefinedApp - , unThunk - , etaConvert - , evaluateIifes - , inlineVariables - , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x] - , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x] - , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer - , inlineCommonOperators ]) +optimize :: (Monad m, MonadReader (Options mode) m) => JS -> m JS +optimize js = do + noOpt <- asks optionsNoOptimizations + if noOpt then return js else optimize' js + +optimize' :: (Monad m, MonadReader (Options mode) m) => JS -> m JS +optimize' js = do + opts <- ask + return $ untilFixedPoint (applyAll + [ collapseNestedBlocks + , collapseNestedIfs + , tco opts + , magicDo opts + , removeCodeAfterReturnStatements + , removeUnusedArg + , removeUndefinedApp + , unThunk + , etaConvert + , evaluateIifes + , inlineVariables + , inlineValues + , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x] + , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x] + , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer + , inlineCommonOperators ]) js untilFixedPoint :: (Eq a) => (a -> a) -> a -> a untilFixedPoint f = go where go a = let a' = f a in if a' == a then a' else go a' - diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index a4dc800..caf7017 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -15,6 +15,7 @@ module Language.PureScript.CodeGen.JS.Optimizer.Inliner ( inlineVariables, + inlineValues, inlineOperator, inlineCommonOperators, etaConvert, @@ -79,6 +80,15 @@ inlineVariables = everywhereOnJS $ removeFromBlock go go (map (replaceIdent var js) sts) go (s:sts) = s : go sts +inlineValues :: JS -> JS +inlineValues = everywhereOnJS convert + where + convert :: JS -> JS + convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.zero fn = JSNumericLiteral (Left 0) + convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.one fn = JSNumericLiteral (Left 1) + convert (JSApp (JSApp fn [x]) [y]) | isPreludeFn (C.%) fn = JSBinary Modulus x y + convert other = other + inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS inlineOperator (m, op) f = everywhereOnJS convert where @@ -91,12 +101,11 @@ inlineOperator (m, op) f = everywhereOnJS convert inlineCommonOperators :: JS -> JS inlineCommonOperators = applyAll $ - [ binary C.numNumber (C.+) Add - , binary C.numNumber (C.-) Subtract - , binary C.numNumber (C.*) Multiply - , binary C.numNumber (C./) Divide - , binary C.numNumber (C.%) Modulus - , unary C.numNumber C.negate Negate + [ binary C.semiringNumber (C.+) Add + , binary C.semiringNumber (C.*) Multiply + , binary C.ringNumber (C.-) Subtract + , unary C.ringNumber C.negate Negate + , binary C.moduloSemiringNumber (C./) Divide , binary C.ordNumber (C.<) LessThan , binary C.ordNumber (C.>) GreaterThan @@ -131,29 +140,20 @@ inlineCommonOperators = applyAll $ binary dictName opString op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y + convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y convert other = other - isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString) - isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op' - isOp _ = False binaryFunction :: String -> String -> BinaryOperator -> JS -> JS binaryFunction dictName fnName op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y + convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y convert other = other - isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName' - isOp _ = False unary :: String -> String -> UnaryOperator -> JS -> JS unary dictName fnName op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x + convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x convert other = other - isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName - isOp _ = False - isOpDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName - isOpDict _ _ = False mkFn :: Int -> JS -> JS mkFn 0 = everywhereOnJS convert where @@ -189,3 +189,13 @@ inlineCommonOperators = applyAll $ go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc) go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs go _ _ _ = Nothing + +isPreludeDict :: String -> JS -> Bool +isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName +isPreludeDict _ _ = False + +isPreludeFn :: String -> JS -> Bool +isPreludeFn fnName (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName +isPreludeFn fnName (JSIndexer (JSStringLiteral fnName') (JSVar prelude)) = prelude == C.prelude && fnName' == fnName +isPreludeFn fnName (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op fnName) +isPreludeFn _ _ = False diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index fb4952b..51ba984 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -105,6 +105,12 @@ not = "not" -- Prelude Values +zero :: String +zero = "zero" + +one :: String +one = "one" + return :: String return = "return" @@ -163,6 +169,15 @@ applicativeEffDictionary = "applicativeEff" bindEffDictionary :: String bindEffDictionary = "bindEff" +semiringNumber :: String +semiringNumber = "semiringNumber" + +ringNumber :: String +ringNumber = "ringNumber" + +moduloSemiringNumber :: String +moduloSemiringNumber = "moduloSemiringNumber" + numNumber :: String numNumber = "numNumber" diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index c88dceb..595f2cc 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -13,6 +13,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} module Language.PureScript.CoreFn.Binders where @@ -44,4 +45,4 @@ data Binder a -- | -- A binder which binds its input to an identifier -- - | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable) + | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable, Functor) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 35e6eec..cc5e16c 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -40,14 +40,148 @@ import qualified Language.PureScript.AST as A -- Desugars a module from AST to CoreFn representation. -- moduleToCoreFn :: Environment -> A.Module -> Module Ann +moduleToCoreFn _ (A.Module _ _ Nothing) = + error "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn env (A.Module mn decls (Just exps)) = let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls exps' = nub $ concatMap exportToCoreFn exps externs = nub $ mapMaybe externToCoreFn decls - decls' = concatMap (declToCoreFn env Nothing []) decls + decls' = concatMap (declToCoreFn Nothing []) decls in Module mn imports exps' externs decls' -moduleToCoreFn _ (A.Module{}) = - error "Module exports were not elaborated before moduleToCoreFn" + + where + + -- | + -- Desugars member declarations from AST to CoreFn representation. + -- + declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann] + declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) = + [NonRec (properToIdent ctor) $ + Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))] + declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) = + error $ "Found newtype with multiple constructors: " ++ show d + declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) = + flip map ctors $ \(ctor, _) -> + let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) + in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields + declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds + declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) = + [NonRec name (exprToCoreFn ss com Nothing e)] + declToCoreFn ss _ (A.BindingGroupDeclaration ds) = + [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds] + declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) = + [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members] + declToCoreFn _ com (A.PositionedDeclaration ss com1 d) = + declToCoreFn (Just ss) (com ++ com1) d + declToCoreFn _ _ _ = [] + + -- | + -- Desugars expressions from AST to CoreFn representation. + -- + exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann + exprToCoreFn ss com ty (A.NumericLiteral v) = + Literal (ss, com, ty, Nothing) (NumericLiteral v) + exprToCoreFn ss com ty (A.StringLiteral v) = + Literal (ss, com, ty, Nothing) (StringLiteral v) + exprToCoreFn ss com ty (A.BooleanLiteral v) = + Literal (ss, com, ty, Nothing) (BooleanLiteral v) + exprToCoreFn ss com ty (A.ArrayLiteral vs) = + Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs) + exprToCoreFn ss com ty (A.ObjectLiteral vs) = + Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs) + exprToCoreFn ss com ty (A.Accessor name v) = + Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) + exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = + ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs + exprToCoreFn ss com ty (A.Abs (Left name) v) = + Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) + exprToCoreFn _ _ _ (A.Abs _ _) = + error "Abs with Binder argument was not desugared before exprToCoreFn mn" + exprToCoreFn ss com ty (A.App v1 v2) = + App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2) + exprToCoreFn ss com ty (A.Var ident) = + Var (ss, com, ty, Nothing) ident + exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = + Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1] + [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True] + (Right $ exprToCoreFn Nothing [] Nothing v2) + , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False] + (Right $ exprToCoreFn Nothing [] Nothing v3) ] + exprToCoreFn ss com ty (A.Constructor name) = + Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name + exprToCoreFn ss com ty (A.Case vs alts) = + Case (ss, com, ty, Nothing) (map (exprToCoreFn ss [] Nothing) vs) (map (altToCoreFn ss) alts) + exprToCoreFn ss com _ (A.TypedValue _ v ty) = + exprToCoreFn ss com (Just ty) v + exprToCoreFn ss com ty (A.Let ds v) = + Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v) + exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) = + let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs + ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) + in foldl (App (ss, com, Nothing, Nothing)) ctor args + exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) = + Abs (ss, com, ty, Nothing) (Ident "dict") + (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict"))) + exprToCoreFn _ com ty (A.PositionedValue ss com1 v) = + exprToCoreFn (Just ss) (com ++ com1) ty v + exprToCoreFn _ _ _ e = + error $ "Unexpected value in exprToCoreFn mn: " ++ show e + + -- | + -- Desugars case alternatives from AST to CoreFn representation. + -- + altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann + altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs) + where + go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann) + go (Left ges) = Left $ map (exprToCoreFn ss [] Nothing *** exprToCoreFn ss [] Nothing) ges + go (Right e) = Right (exprToCoreFn ss [] Nothing e) + + -- | + -- Desugars case binders from AST to CoreFn representation. + -- + binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann + binderToCoreFn ss com (A.NullBinder) = + NullBinder (ss, com, Nothing, Nothing) + binderToCoreFn ss com (A.BooleanBinder b) = + LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b) + binderToCoreFn ss com (A.StringBinder s) = + LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s) + binderToCoreFn ss com (A.NumberBinder n) = + LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n) + binderToCoreFn ss com (A.VarBinder name) = + VarBinder (ss, com, Nothing, Nothing) name + binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) = + let (_, tctor, _, _) = lookupConstructor env dctor + in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs) + binderToCoreFn ss com (A.ObjectBinder bs) = + LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs) + binderToCoreFn ss com (A.ArrayBinder bs) = + LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs) + binderToCoreFn ss com (A.ConsBinder b1 b2) = + let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array") + in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn ss []) [b1, b2] + binderToCoreFn ss com (A.NamedBinder name b) = + NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b) + binderToCoreFn _ com (A.PositionedBinder ss com1 b) = + binderToCoreFn (Just ss) (com ++ com1) b + + -- | + -- Gets metadata for data constructors. + -- + getConstructorMeta :: Qualified ProperName -> Meta + getConstructorMeta ctor = + case lookupConstructor env ctor of + (Newtype, _, _, _) -> IsNewtype + dc@(Data, _, _, fields) -> + let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType + in IsConstructor constructorType fields + where + numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int + numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env + typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName) + typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) + typeConstructor _ = error "Invalid argument to typeConstructor" -- | -- Find module names from qualified references to values. This is used to @@ -94,29 +228,6 @@ exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d exportToCoreFn _ = [] -- | --- Desugars member declarations from AST to CoreFn representation. --- -declToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann] -declToCoreFn _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) = - [NonRec (properToIdent ctor) $ - Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))] -declToCoreFn _ _ _ d@(A.DataDeclaration Newtype _ _ _) = - error $ "Found newtype with multiple constructors: " ++ show d -declToCoreFn _ ss com (A.DataDeclaration Data tyName _ ctors) = - flip map ctors $ \(ctor, tys) -> - NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor (length tys) -declToCoreFn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss []) ds -declToCoreFn env ss com (A.ValueDeclaration name _ _ (Right e)) = - [NonRec name (exprToCoreFn env ss com Nothing e)] -declToCoreFn env ss _ (A.BindingGroupDeclaration ds) = - [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss [] Nothing e)) ds] -declToCoreFn _ ss com (A.TypeClassDeclaration name _ supers members) = - [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members] -declToCoreFn env _ com (A.PositionedDeclaration ss com1 d) = - declToCoreFn env (Just ss) (com ++ com1) d -declToCoreFn _ _ _ _ = [] - --- | -- Makes a typeclass dictionary constructor function. The returned expression -- is a function that accepts the superclass instances and member -- implementations and returns a record for the instance dictionary. @@ -132,116 +243,7 @@ mkTypeClassConstructor ss com supers members = (foldr (Abs nullAnn . Ident) dict as) -- | --- Desugars expressions from AST to CoreFn representation. --- -exprToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann -exprToCoreFn _ ss com ty (A.NumericLiteral v) = - Literal (ss, com, ty, Nothing) (NumericLiteral v) -exprToCoreFn _ ss com ty (A.StringLiteral v) = - Literal (ss, com, ty, Nothing) (StringLiteral v) -exprToCoreFn _ ss com ty (A.BooleanLiteral v) = - Literal (ss, com, ty, Nothing) (BooleanLiteral v) -exprToCoreFn env ss com ty (A.ArrayLiteral vs) = - Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss [] Nothing) vs) -exprToCoreFn env ss com ty (A.ObjectLiteral vs) = - Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss [] Nothing)) vs) -exprToCoreFn env ss com ty (A.Accessor name v) = - Accessor (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v) -exprToCoreFn env ss com ty (A.ObjectUpdate obj vs) = - ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing obj) $ map (second (exprToCoreFn env ss [] Nothing)) vs -exprToCoreFn env ss com ty (A.Abs (Left name) v) = - Abs (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v) -exprToCoreFn _ _ _ _ (A.Abs _ _) = - error "Abs with Binder argument was not desugared before exprToCoreFn" -exprToCoreFn env ss com ty (A.App v1 v2) = - App (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing v1) (exprToCoreFn env ss [] Nothing v2) -exprToCoreFn _ ss com ty (A.Var ident) = - Var (ss, com, ty, Nothing) ident -exprToCoreFn env ss com ty (A.IfThenElse v1 v2 v3) = - Case (ss, com, ty, Nothing) [exprToCoreFn env ss [] Nothing v1] - [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True] - (Right $ exprToCoreFn env Nothing [] Nothing v2) - , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False] - (Right $ exprToCoreFn env Nothing [] Nothing v3) ] -exprToCoreFn env ss com ty (A.Constructor name) = - Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name -exprToCoreFn env ss com ty (A.Case vs alts) = - Case (ss, com, ty, Nothing) (map (exprToCoreFn env ss [] Nothing) vs) (map (altToCoreFn env ss) alts) -exprToCoreFn env ss com _ (A.TypedValue _ v ty) = - exprToCoreFn env ss com (Just ty) v -exprToCoreFn env ss com ty (A.Let ds v) = - Let (ss, com, ty, Nothing) (concatMap (declToCoreFn env ss []) ds) (exprToCoreFn env ss [] Nothing v) -exprToCoreFn env ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) = - let args = map (exprToCoreFn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs - ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) - in foldl (App (ss, com, Nothing, Nothing)) ctor args -exprToCoreFn env _ com ty (A.PositionedValue ss com1 v) = - exprToCoreFn env (Just ss) (com ++ com1) ty v -exprToCoreFn _ _ _ _ e = - error $ "Unexpected value in exprToCoreFn: " ++ show e - --- | --- Desugars case alternatives from AST to CoreFn representation. --- -altToCoreFn :: Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann -altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs) - where - go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann) - go (Left ges) = Left $ map (exprToCoreFn env ss [] Nothing *** exprToCoreFn env ss [] Nothing) ges - go (Right e) = Right (exprToCoreFn env ss [] Nothing e) - --- | --- Desugars case binders from AST to CoreFn representation. --- -binderToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann -binderToCoreFn _ ss com (A.NullBinder) = - NullBinder (ss, com, Nothing, Nothing) -binderToCoreFn _ ss com (A.BooleanBinder b) = - LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b) -binderToCoreFn _ ss com (A.StringBinder s) = - LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s) -binderToCoreFn _ ss com (A.NumberBinder n) = - LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n) -binderToCoreFn _ ss com (A.VarBinder name) = - VarBinder (ss, com, Nothing, Nothing) name -binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) = - let (_, tctor, _) = lookupConstructor env dctor - in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss []) bs) -binderToCoreFn env ss com (A.ObjectBinder bs) = - LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs) -binderToCoreFn env ss com (A.ArrayBinder bs) = - LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss []) bs) -binderToCoreFn env ss com (A.ConsBinder b1 b2) = - let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array") - in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss []) [b1, b2] -binderToCoreFn env ss com (A.NamedBinder name b) = - NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn env ss [] b) -binderToCoreFn env _ com (A.PositionedBinder ss com1 b) = - binderToCoreFn env (Just ss) (com ++ com1) b - --- | -- Converts a ProperName to an Ident. -- properToIdent :: ProperName -> Ident properToIdent = Ident . runProperName - --- | --- Gets metadata for data constructors. --- -getConstructorMeta :: Environment -> Qualified ProperName -> Meta -getConstructorMeta env ctor = - case lookupConstructor env ctor of - (Newtype, _, _) -> IsNewtype - dc@(Data, _, ty) -> - let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType - in IsConstructor constructorType (getArity ty) - where - getArity :: Type -> Int - getArity (TypeApp (TypeApp f _) t) | f == tyFunction = getArity t + 1 - getArity (ForAll _ ty _) = getArity ty - getArity _ = 0 - numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int - numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env - typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName) - typeConstructor (Qualified (Just mn) _, (_, tyCtor, _)) = (mn, tyCtor) - typeConstructor _ = error "Invalid argument to typeConstructor" diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 02fa24d..67decc3 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -13,14 +13,16 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} module Language.PureScript.CoreFn.Expr where +import Control.Arrow ((***)) + import qualified Data.Data as D import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Literals -import Language.PureScript.CoreFn.Meta import Language.PureScript.Names -- | @@ -32,9 +34,9 @@ data Expr a -- = Literal a (Literal (Expr a)) -- | - -- A data constructor (type name, constructor name, arity) + -- A data constructor (type name, constructor name, field names) -- - | Constructor a ProperName ProperName Arity + | Constructor a ProperName ProperName [Ident] -- | -- A record property accessor -- @@ -62,7 +64,7 @@ data Expr a -- | -- A let binding -- - | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable) + | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable, Functor) -- | -- A let or module binding. @@ -75,7 +77,7 @@ data Bind a -- | -- Mutually recursive binding group for several values -- - | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable) + | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor) -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders @@ -96,6 +98,12 @@ data CaseAlternative a = CaseAlternative , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) } deriving (Show, D.Data, D.Typeable) +instance Functor CaseAlternative where + + fmap f (CaseAlternative cabs car) = CaseAlternative + (fmap (fmap f) $ cabs) + (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car) + -- | -- Extract the annotation from a term -- @@ -110,6 +118,7 @@ extractAnn (Var a _) = a extractAnn (Case a _ _) = a extractAnn (Let a _ _) = a + -- | -- Modify the annotation on a term -- diff --git a/src/Language/PureScript/CoreFn/Literals.hs b/src/Language/PureScript/CoreFn/Literals.hs index 8e56d97..e610566 100644 --- a/src/Language/PureScript/CoreFn/Literals.hs +++ b/src/Language/PureScript/CoreFn/Literals.hs @@ -13,6 +13,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} module Language.PureScript.CoreFn.Literals where @@ -42,4 +43,4 @@ data Literal a -- | -- An object literal -- - | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable) + | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor) diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index 7c2199c..84859bc 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -18,6 +18,8 @@ module Language.PureScript.CoreFn.Meta where import qualified Data.Data as D +import Language.PureScript.Names + -- | -- Metadata annotations -- @@ -25,7 +27,7 @@ data Meta -- | -- The contained value is a data constructor -- - = IsConstructor ConstructorType Arity + = IsConstructor ConstructorType [Ident] -- | -- The contained value is a newtype -- @@ -36,11 +38,6 @@ data Meta | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable) -- | --- Type alias for constructor arity --- -type Arity = Int - --- | -- Data constructor metadata -- data ConstructorType diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 71472e3..29096d5 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -41,7 +41,7 @@ data Environment = Environment { -- | -- Data constructors currently in scope, along with their associated data type constructors -- - , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type) + , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident]) -- | -- Type synonyms currently in scope -- @@ -228,7 +228,7 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star -- | -- Finds information about data constructors from the current environment. -- -lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type) +lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident]) lookupConstructor env ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env @@ -237,5 +237,5 @@ lookupConstructor env ctor = -- isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool isNewtypeConstructor e ctor = case lookupConstructor e ctor of - (Newtype, _, _) -> True - (Data, _, _) -> False + (Newtype, _, _, _) -> True + (Data, _, _, _) -> False diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4ced126..3ff82ff 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -17,10 +17,11 @@ module Language.PureScript.Errors where import Data.Either (lefts, rights) +import Data.String (IsString(..)) import Data.List (intersperse, intercalate) import Data.Monoid -import Control.Monad.Error +import Control.Monad.Except import Control.Applicative ((<$>)) import Language.PureScript.AST @@ -67,15 +68,14 @@ data ErrorStack = ErrorStack { runErrorStack :: [CompileError] } | MultipleErrors [ErrorStack] deriving (Show) -instance Monoid ErrorStack where - mempty = ErrorStack [] - mappend (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys) - mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ] - mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ] +-- TODO: Remove strMsg, the IsString instance, and unnecessary +-- OverloadedStrings pragmas. See #745 +-- | Create an ErrorStack from a string +strMsg :: String -> ErrorStack +strMsg s = ErrorStack [CompileError s Nothing Nothing] -instance Error ErrorStack where - strMsg s = ErrorStack [CompileError s Nothing Nothing] - noMsg = ErrorStack [] +instance IsString ErrorStack where + fromString = strMsg prettyPrintErrorStack :: Bool -> ErrorStack -> String prettyPrintErrorStack printFullStack (ErrorStack es) = @@ -95,8 +95,8 @@ prettyPrintErrorStack printFullStack (ErrorStack es) = prettyPrintErrorStack printFullStack (MultipleErrors es) = unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es -stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a -stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right +stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a +stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return isErrorNonEmpty :: CompileError -> Bool isErrorNonEmpty = not . null . compileErrorMessage @@ -107,10 +107,13 @@ showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " + showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack -mkErrorStack msg t = ErrorStack [CompileError msg t Nothing] +mkErrorStack msg t = ErrorStack [mkCompileError msg t] -positionError :: SourceSpan -> ErrorStack -positionError pos = ErrorStack [CompileError "" Nothing (Just pos)] +mkCompileError :: String -> Maybe ErrorSource -> CompileError +mkCompileError msg t = CompileError msg t Nothing + +positionError :: SourceSpan -> CompileError +positionError pos = CompileError "" Nothing (Just pos) -- | -- Rethrow an error with a more detailed error message in the case of failure @@ -122,7 +125,7 @@ rethrow f = flip catchError $ \e -> throwError (f e) -- Rethrow an error with source position information -- rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a -rethrowWithPosition pos = rethrow (positionError pos <>) +rethrowWithPosition pos = rethrow (positionError pos `combineErrors`) -- | -- Collect errors in in parallel @@ -138,3 +141,13 @@ parU xs f = forM xs (withError . f) >>= collectErrors [err] -> throwError err [] -> return $ rights es errs -> throwError $ MultipleErrors errs + +-- | +-- Add an extra error string onto the top of each error stack in a list of possibly many errors +-- +combineErrors :: CompileError -> ErrorStack -> ErrorStack +combineErrors ce err = go (ErrorStack [ce]) err + where + go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys) + go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ] + go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ] diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 4a9cb20..71e516f 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -12,11 +12,15 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} + module Language.PureScript.ModuleDependencies ( sortModules, ModuleGraph ) where +import Control.Monad.Except + import Data.Graph import Data.List (nub) import Data.Maybe (mapMaybe) @@ -35,7 +39,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])] -- -- Reports an error if the module graph contains a cycle. -- -sortModules :: [Module] -> Either String ([Module], ModuleGraph) +sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph) sortModules ms = do let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms ms' <- mapM toModule $ stronglyConnComp verts @@ -66,7 +70,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues ( -- | -- Convert a strongly connected component of the module graph to a module -- -toModule :: SCC Module -> Either String Module +toModule :: (MonadError String m) => SCC Module -> m Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m -toModule (CyclicSCC ms) = Left $ "Cycle in module dependencies: " ++ show (map getModuleName ms) +toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms) diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 421ab1f..a7265f4 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -70,6 +70,9 @@ data Options mode = Options { -- , optionsVerboseErrors :: Bool -- | + -- Remove the comments from the generated js + , optionsNoComments :: Bool + -- | -- Specify the namespace that PureScript modules will be exported to when running in the -- browser. -- @@ -80,10 +83,10 @@ data Options mode = Options { -- Default compiler options -- defaultCompileOptions :: Options Compile -defaultCompileOptions = Options False False False Nothing False False (CompileOptions "PS" [] []) +defaultCompileOptions = Options False False False Nothing False False False (CompileOptions "PS" [] []) -- | -- Default make options -- defaultMakeOptions :: Options Make -defaultMakeOptions = Options False False False Nothing False False MakeOptions +defaultMakeOptions = Options False False False Nothing False False False MakeOptions diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 38841aa..c477180 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -24,7 +24,6 @@ module Language.PureScript.Sugar.BindingGroups ( import Data.Graph import Data.List (nub, intersect) import Data.Maybe (isJust, mapMaybe) -import Data.Monoid ((<>)) import Control.Applicative ((<$>), (<*>), pure) import Control.Monad ((<=<)) @@ -181,7 +180,7 @@ toBindingGroup moduleName (CyclicSCC ds') = cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $ mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e)) - cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d [] + cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d [] cycleError _ _ = error "Expected ValueDeclaration" toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 842c0fb..dde2428 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -19,12 +19,11 @@ module Language.PureScript.Sugar.CaseDeclarations ( desugarCasesModule ) where -import Data.Monoid ((<>)) import Data.List (nub, groupBy) import Control.Applicative import Control.Monad ((<=<), forM, join, unless, replicateM) -import Control.Monad.Error.Class +import Control.Monad.Except (throwError) import Language.PureScript.Names import Language.PureScript.AST @@ -44,7 +43,7 @@ isLeft (Right _) = False -- desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module] desugarCasesModule ms = forM ms $ \(Module name ds exps) -> - rethrow (strMsg ("Error in module " ++ show name) <>) $ + rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $ Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 31eb7d7..fc22e34 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -18,10 +18,9 @@ module Language.PureScript.Sugar.Names ( import Data.List (nub) import Data.Maybe (fromMaybe, isJust, mapMaybe) -import Data.Monoid ((<>)) import Control.Applicative (Applicative(..), (<$>), (<*>)) -import Control.Monad.Error +import Control.Monad.Except import qualified Data.Map as M @@ -166,7 +165,7 @@ desugarImports modules = do -- the module has access to an unfiltered list of its own members. renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module renameInModule' unfilteredExports exports m@(Module mn _ _) = - rethrow (strMsg ("Error in module " ++ show mn) <>) $ do + rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ do let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports imports <- resolveImports env m @@ -233,7 +232,8 @@ renameInModule imports exports (Module mn decls exps) = updateValue (pos, bound) (Let ds val') = do let args = mapMaybe letBoundVariable ds unless (length (nub args) == length args) $ - throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing + maybe id rethrowWithPosition pos $ + throwError $ mkErrorStack ("Overlapping names in let binding.") Nothing return ((pos, args ++ bound), Let ds val') where updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = @@ -318,7 +318,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment addModule env (Module mn ds _) = do env' <- addEmptyModule env mn - rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds + rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ foldM (addDecl mn) env' ds -- Add a declaration from a module to the global export environment addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment @@ -344,7 +344,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment filterExports mn exps env = do let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env) - moduleExports' <- rethrow (strMsg ("Error in module " ++ show mn) <>) $ filterModule moduleExports + moduleExports' <- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ filterModule moduleExports return $ M.insert mn moduleExports' env where diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 2120d8b..9038e63 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -32,9 +32,8 @@ import Language.PureScript.Supply import Control.Applicative import Control.Monad.State -import Control.Monad.Error.Class +import Control.Monad.Except -import Data.Monoid ((<>)) import Data.Function (on) import Data.Functor.Identity import Data.List (groupBy, sortBy) @@ -90,7 +89,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m go [] = return () go [_] = return () go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y = - rethrow (strMsg ("Error in module " ++ show mn) <>) $ + rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ rethrowWithPosition pos $ throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing go (_ : rest) = go rest diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 49a8dc9..ed08fc2 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -21,23 +21,22 @@ module Language.PureScript.Sugar.TypeClasses ) where import Language.PureScript.AST hiding (isExported) -import Language.PureScript.Names -import Language.PureScript.Types -import Language.PureScript.Kinds -import Language.PureScript.Sugar.CaseDeclarations import Language.PureScript.Environment import Language.PureScript.Errors -import Language.PureScript.Supply +import Language.PureScript.Kinds +import Language.PureScript.Names import Language.PureScript.Pretty.Types (prettyPrintTypeAtom) +import Language.PureScript.Sugar.CaseDeclarations +import Language.PureScript.Supply +import Language.PureScript.Types import qualified Language.PureScript.Constants as C import Control.Applicative -import Control.Monad.Error -import Control.Monad.State import Control.Arrow (first, second) +import Control.Monad.Except +import Control.Monad.State import Data.List ((\\), find) -import Data.Monoid ((<>)) import Data.Maybe (catMaybes, mapMaybe, isJust) import qualified Data.Map as M @@ -158,12 +157,12 @@ desugarDecl mn exps = go where go d@(TypeClassDeclaration name args implies members) = do modify (M.insert (mn, name) d) - return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) + return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d]) go d@(TypeInstanceDeclaration name deps className tys members) = do desugared <- lift $ desugarCases members dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared - return $ (expRef name className tys, [d, dictDecl]) + return (expRef name className tys, [d, dictDecl]) go (PositionedDeclaration pos com d) = do (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d return (dr, map (PositionedDeclaration pos com) ds) @@ -212,9 +211,10 @@ typeClassDictionaryDeclaration name args implies members = typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = - ValueDeclaration ident TypeClassAccessorImport [] $ Right $ - TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $ - moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty)) + let className = Qualified (Just mn) name + in ValueDeclaration ident TypeClassAccessorImport [] $ Right $ + TypedValue False (TypeClassDictionaryAccessor className ident) $ + moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition" @@ -224,7 +224,7 @@ unit = TypeApp tyObject REmpty typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration typeInstanceDictionaryDeclaration name mn deps className tys decls = - rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do + rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do m <- get -- Lookup the type arguments and member types for the type class diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index aa4427e..7779fd1 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -19,11 +19,9 @@ module Language.PureScript.Sugar.TypeDeclarations ( desugarTypeDeclarationsModule ) where -import Data.Monoid ((<>)) - import Control.Applicative -import Control.Monad.Error.Class import Control.Monad (forM) +import Control.Monad.Except (throwError) import Language.PureScript.AST import Language.PureScript.Names @@ -36,7 +34,7 @@ import Language.PureScript.Traversals -- desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> - rethrow (strMsg ("Error in module " ++ show name) <>) $ + rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $ Module name <$> desugarTypeDeclarations ds <*> pure exps -- | diff --git a/src/Language/PureScript/Supply.hs b/src/Language/PureScript/Supply.hs index c11725b..8ff03c8 100644 --- a/src/Language/PureScript/Supply.hs +++ b/src/Language/PureScript/Supply.hs @@ -24,7 +24,7 @@ import Data.Functor.Identity import Control.Applicative import Control.Monad.State -import Control.Monad.Error.Class +import Control.Monad.Except newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 150df69..bc5c64d 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -27,12 +27,11 @@ import Language.PureScript.TypeChecker.Synonyms as T import Data.Maybe import Data.List (nub, (\\), find, intercalate) -import Data.Monoid ((<>)) import Data.Foldable (for_) import qualified Data.Map as M import Control.Monad.State -import Control.Monad.Error +import Control.Monad.Except import Language.PureScript.Types import Language.PureScript.Names @@ -47,7 +46,7 @@ addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) } forM_ dctors $ \(dctor, tys) -> - rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $ + rethrow (mkCompileError ("Error in data constructor " ++ show dctor) Nothing `combineErrors`) $ addDataConstructor moduleName dtype name (map fst args) dctor tys addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check () @@ -57,7 +56,8 @@ addDataConstructor moduleName dtype name args dctor tys = do let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args) let dctorTy = foldr function retTy tys let polyType = mkForAll args dctorTy - putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) } + let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]] + putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check () addTypeSynonym moduleName name args ty kind = do @@ -133,7 +133,7 @@ typeCheckAll mainModuleName moduleName exps = go go :: [Declaration] -> Check [Declaration] go [] = return [] go (DataDeclaration dtype name args dctors : rest) = do - rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do + rethrow (mkCompileError ("Error in type constructor " ++ show name) Nothing `combineErrors`) $ do when (dtype == Newtype) $ checkNewtype dctors checkDuplicateTypeArguments $ map fst args ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) @@ -147,7 +147,7 @@ typeCheckAll mainModuleName moduleName exps = go checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument" checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor" go (d@(DataBindingGroupDeclaration tys) : rest) = do - rethrow (strMsg "Error in data binding group" <>) $ do + rethrow (mkCompileError "Error in data binding group" Nothing `combineErrors`) $ do let syns = mapMaybe toTypeSynonym tys let dataDecls = mapMaybe toDataDecl tys (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) @@ -169,7 +169,7 @@ typeCheckAll mainModuleName moduleName exps = go toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d' toDataDecl _ = Nothing go (TypeSynonymDeclaration name args ty : rest) = do - rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do + rethrow (mkCompileError ("Error in type synonym " ++ show name) Nothing `combineErrors`) $ do checkDuplicateTypeArguments $ map fst args kind <- kindsOf False moduleName name args [ty] let args' = args `withKinds` kind @@ -178,7 +178,7 @@ typeCheckAll mainModuleName moduleName exps = go return $ TypeSynonymDeclaration name args ty : ds go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed" go (ValueDeclaration name nameKind [] (Right val) : rest) = do - d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do + d <- rethrow (mkCompileError ("Error in declaration " ++ show name) Nothing `combineErrors`) $ do valueIsNotDefined moduleName name [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)] addValue moduleName name ty nameKind @@ -187,7 +187,7 @@ typeCheckAll mainModuleName moduleName exps = go return $ d : ds go (ValueDeclaration{} : _) = error "Binders were not desugared" go (BindingGroupDeclaration vals : rest) = do - d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do + d <- rethrow (mkCompileError ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) Nothing `combineErrors`) $ do forM_ (map (\(ident, _, _) -> ident) vals) $ \name -> valueIsNotDefined moduleName name tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals @@ -207,7 +207,7 @@ typeCheckAll mainModuleName moduleName exps = go ds <- go rest return $ d : ds go (d@(ExternDeclaration importTy name _ ty) : rest) = do - rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do + rethrow (mkCompileError ("Error in foreign import declaration " ++ show name) Nothing `combineErrors`) $ do env <- getEnv kind <- kindOf moduleName ty guardWith (strMsg "Expected kind *") $ kind == Star diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 6486860..c86f979 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -25,9 +25,10 @@ import qualified Data.Map as M import Control.Applicative import Control.Arrow (Arrow(..)) -import Control.Monad.Error +import Control.Monad.Except import Language.PureScript.AST +import Language.PureScript.Errors import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.Pretty diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 60083cc..fa3d630 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -24,14 +24,13 @@ module Language.PureScript.TypeChecker.Kinds ( ) where import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import qualified Data.HashMap.Strict as H import qualified Data.Map as M import Control.Arrow (second) import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State import Control.Monad.Unify @@ -79,7 +78,7 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty -- kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)]) kindOfWithScopedVars ty = - rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $ + rethrow (mkCompileError "Error checking kind" (Just (TypeError ty)) `combineErrors`) $ fmap tidyUp . liftUnify $ infer ty where tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k) @@ -157,7 +156,7 @@ starIfUnknown k = k -- Infer a kind for a type -- infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)]) -infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty +infer ty = rethrow (mkCompileError "Error inferring type of value" (Just (TypeError ty)) `combineErrors`) $ infer' ty infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)]) infer' (ForAll ident ty _) = do diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index b59c08a..7abb0ac 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes, - MultiParamTypeClasses, FlexibleContexts #-} + MultiParamTypeClasses, FlexibleContexts, GADTs #-} module Language.PureScript.TypeChecker.Monad where @@ -22,7 +22,8 @@ import Data.Maybe import qualified Data.Map as M import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except +import Control.Monad.Reader.Class import Control.Monad.State import Control.Monad.Unify @@ -108,7 +109,7 @@ makeBindingGroupVisible action = do -- | -- Lookup the type of a value by name in the @Environment@ -- -lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type +lookupVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type lookupVariable currentModule (Qualified moduleName var) = do env <- getEnv case M.lookup (fromMaybe currentModule moduleName, var) (names env) of @@ -118,7 +119,7 @@ lookupVariable currentModule (Qualified moduleName var) = do -- | -- Lookup the visibility of a value by name in the @Environment@ -- -getVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility +getVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility getVisibility currentModule (Qualified moduleName var) = do env <- getEnv case M.lookup (fromMaybe currentModule moduleName, var) (names env) of @@ -128,7 +129,7 @@ getVisibility currentModule (Qualified moduleName var) = do -- | -- Assert that a name is visible -- -checkVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m () +checkVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m () checkVisibility currentModule name@(Qualified _ var) = do vis <- getVisibility currentModule name case vis of @@ -138,7 +139,7 @@ checkVisibility currentModule name@(Qualified _ var) = do -- | -- Lookup the kind of a type by name in the @Environment@ -- -lookupTypeVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind +lookupTypeVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind lookupTypeVariable currentModule (Qualified moduleName name) = do env <- getEnv case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of @@ -171,7 +172,7 @@ data CheckState = CheckState { -- The type checking monad, which provides the state of the type checker, and error reporting capabilities -- newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a } - deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadState CheckState, MonadError ErrorStack) + deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError ErrorStack) -- | -- Get the current @Environment@ @@ -194,14 +195,16 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) -- | -- Run a computation in the Check monad, starting with an empty @Environment@ -- -runCheck :: Options mode -> Check a -> Either String (a, Environment) -runCheck opts = runCheck' opts initEnvironment +runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment) +runCheck = runCheck' initEnvironment -- | -- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@. -- -runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment) -runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do +runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment) +runCheck' env c = do + verbose <- asks optionsVerboseErrors + stringifyErrorStack verbose $ do (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c return (a, checkEnv s) diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs index 1c3115a..f1fec1b 100644 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -19,7 +19,7 @@ module Language.PureScript.TypeChecker.Rows ( import Data.List -import Control.Monad.Error +import Control.Monad.Except import Language.PureScript.AST import Language.PureScript.Errors diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 62ee80a..221cb1a 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -26,7 +26,7 @@ import Data.List (nub, (\\)) import Data.Monoid import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.Unify import Language.PureScript.AST diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 5d8ab24..e9a7ac2 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -18,11 +18,10 @@ module Language.PureScript.TypeChecker.Subsumption ( ) where import Data.List (sortBy) -import Data.Monoid import Data.Ord (comparing) import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.Unify import Language.PureScript.AST @@ -39,7 +38,7 @@ import Language.PureScript.Types -- Check whether one type subsumes another, rethrowing errors to provide a better error message -- subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr) -subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2 +subsumes val ty1 ty2 = rethrow (mkCompileError errorMessage (ExprError <$> val) `combineErrors`) $ subsumes' val ty1 ty2 where errorMessage = "Error checking that type " ++ prettyPrintType ty1 diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 7ad00e2..1457a8c 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, GADTs #-} module Language.PureScript.TypeChecker.Synonyms ( saturateAllTypeSynonyms, @@ -28,10 +28,11 @@ import Data.Maybe (fromMaybe) import qualified Data.Map as M import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State import Language.PureScript.Environment +import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types @@ -82,7 +83,7 @@ replaceAllTypeSynonyms' env d = in saturateAllTypeSynonyms syns d -replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type +replaceAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type replaceAllTypeSynonyms d = do env <- getEnv either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d @@ -98,12 +99,12 @@ expandTypeSynonym' env name args = replaceAllTypeSynonyms' env repl Nothing -> error "Type synonym was not defined" -expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type +expandTypeSynonym :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type expandTypeSynonym name args = do env <- getEnv either (throwError . strMsg) return $ expandTypeSynonym' env name args -expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type +expandAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type expandAllTypeSynonyms = everywhereOnTypesTopDownM go where go (SaturatedTypeSynonym name args) = expandTypeSynonym name args diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 49f7d0d..7ad5a97 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-} module Language.PureScript.TypeChecker.Types ( typesOf @@ -38,11 +38,11 @@ module Language.PureScript.TypeChecker.Types ( import Data.Either (lefts, rights) import Data.List import Data.Maybe (fromMaybe) -import Data.Monoid import qualified Data.Map as M +import Data.String (IsString) import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State import Control.Monad.Unify @@ -207,7 +207,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- Infer a type for a value, rethrowing any error to provide a more useful error message -- infer :: Expr -> UnifyT Type Check Expr -infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ExprError val)) <>) $ infer' val +infer val = rethrow (mkCompileError "Error inferring type of value" (Just (ExprError val)) `combineErrors`) $ infer' val -- | -- Infer a type for a value @@ -270,8 +270,8 @@ infer' v@(Constructor c) = do env <- getEnv case M.lookup c (dataConstructors env) of Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined" - Just (_, _, ty) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty - return $ TypedValue True v' ty' + Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty + return $ TypedValue True v' ty' infer' (Case vals binders) = do ts <- mapM infer vals ret <- fresh @@ -355,7 +355,7 @@ inferBinder val (VarBinder name) = return $ M.singleton name val inferBinder val (ConstructorBinder ctor binders) = do env <- getEnv case M.lookup ctor (dataConstructors env) of - Just (_, _, ty) -> do + Just (_, _, ty, _) -> do (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn go binders fn' @@ -427,7 +427,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do -- Check the type of a value, rethrowing errors to provide a better error message -- check :: Expr -> Type -> UnifyT Type Check Expr -check val ty = rethrow (mkErrorStack errorMessage (Just (ExprError val)) <>) $ check' val ty +check val ty = rethrow (mkCompileError errorMessage (Just (ExprError val)) `combineErrors`) $ check' val ty where errorMessage = "Error checking type of term " ++ @@ -552,7 +552,7 @@ check' (Constructor c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined" - Just (_, _, ty1) -> do + Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 _ <- subsumes Nothing repl ty return $ TypedValue True (Constructor c) ty @@ -583,7 +583,7 @@ containsTypeSynonyms = everythingOnTypes (||) go where checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)] checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where go [] [] REmpty = return [] - go [] [] u@(TUnknown _) + go [] [] u@(TUnknown _) | lax = return [] | otherwise = do u =?= REmpty return [] @@ -609,7 +609,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where -- Check the type of a function application, rethrowing errors to provide a better error message -- checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr) -checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ExprError fn)) <>) $ do +checkFunctionApplication fn fnTy arg ret = rethrow (mkCompileError errorMessage (Just (ExprError fn)) `combineErrors`) $ do subst <- unifyCurrentSubstitution <$> UnifyT get checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret) where @@ -673,5 +673,5 @@ meet e1 e2 t1 t2 = do -- | -- Ensure a set of property names and value does not contain duplicate labels -- -ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m () -ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps +ensureNoDuplicateProperties :: (IsString e, MonadError e m) => [(String, Expr)] -> m () +ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 197ca9a..48381a2 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -27,10 +27,9 @@ module Language.PureScript.TypeChecker.Unify ( import Data.List (nub, sort) import Data.Maybe (fromMaybe) -import Data.Monoid import qualified Data.HashMap.Strict as H -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.Unify import Language.PureScript.Environment @@ -61,7 +60,7 @@ instance Unifiable Check Type where -- Unify two types, updating the current substitution -- unifyTypes :: Type -> Type -> UnifyT Type Check () -unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $ +unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing `combineErrors`) $ unifyTypes' t1 t2 where unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () diff --git a/tests/Main.hs b/tests/Main.hs index bfc9930..47922b0 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -22,6 +22,7 @@ import Data.List (isSuffixOf) import Data.Traversable (traverse) import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.Reader (runReaderT) import Control.Applicative import System.Exit import System.Process @@ -38,7 +39,7 @@ loadPrelude :: Either String (String, String, P.Environment) loadPrelude = case P.parseModulesFromFiles id [("", P.prelude)] of Left parseError -> Left (show parseError) - Right ms -> P.compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) (map snd ms) [] + Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] } compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment)) compile opts inputFiles = do @@ -46,7 +47,7 @@ compile opts inputFiles = do case modules of Left parseError -> return (Left $ show parseError) - Right ms -> return $ P.compile opts (map snd ms) [] + Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO () assert preludeExterns opts inputFile f = do -- cgit v0.10.2