summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2015-01-08 23:28:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-01-08 23:28:00 (GMT)
commit27ee9e728366a604461898d7319a41d33cbcea7e (patch)
treefb5a19d00fcd573bcc1ba9252baf4b35f9322ec1
parentec83a8ba6a1e656a603ccbef6b6b4fdc4fe28bf1 (diff)
version 0.6.30.6.3
-rw-r--r--examples/failing/Eff.purs12
-rw-r--r--examples/failing/UnderscoreModuleName.purs3
-rw-r--r--examples/passing/CaseInDo.purs20
-rw-r--r--examples/passing/Eff.purs6
-rw-r--r--examples/passing/ForeignInstance.purs4
-rw-r--r--examples/passing/Objects.purs5
-rw-r--r--examples/passing/TypeWildcardsRecordExtension.purs6
-rw-r--r--examples/passing/UnderscoreIdent.purs9
-rw-r--r--hierarchy/Main.hs8
-rw-r--r--prelude/prelude.purs2
-rw-r--r--psc-docs/Main.hs65
-rw-r--r--psc-make/Main.hs6
-rw-r--r--psc/Main.hs5
-rw-r--r--psci/Commands.hs25
-rw-r--r--psci/Main.hs150
-rw-r--r--psci/Parser.hs128
-rw-r--r--purescript.cabal59
-rw-r--r--src/Language/PureScript.hs81
-rw-r--r--src/Language/PureScript/AST/Binders.hs5
-rw-r--r--src/Language/PureScript/AST/Declarations.hs96
-rw-r--r--src/Language/PureScript/AST/Traversals.hs48
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs22
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs399
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs11
-rw-r--r--src/Language/PureScript/CodeGen/JS/Common.hs (renamed from src/Language/PureScript/CodeGen/Common.hs)54
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs (renamed from src/Language/PureScript/Optimizer.hs)16
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs (renamed from src/Language/PureScript/Optimizer/Blocks.hs)4
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs (renamed from src/Language/PureScript/Optimizer/Common.hs)4
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs (renamed from src/Language/PureScript/Optimizer/Inliner.hs)9
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs (renamed from src/Language/PureScript/Optimizer/MagicDo.hs)29
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs (renamed from src/Language/PureScript/Optimizer/TCO.hs)4
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs (renamed from src/Language/PureScript/Optimizer/Unused.hs)6
-rw-r--r--src/Language/PureScript/Comments.hs25
-rw-r--r--src/Language/PureScript/CoreFn.hs26
-rw-r--r--src/Language/PureScript/CoreFn/Ann.hs37
-rw-r--r--src/Language/PureScript/CoreFn/Binders.hs47
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs242
-rw-r--r--src/Language/PureScript/CoreFn/Expr.hs125
-rw-r--r--src/Language/PureScript/CoreFn/Literals.hs45
-rw-r--r--src/Language/PureScript/CoreFn/Meta.hs54
-rw-r--r--src/Language/PureScript/CoreFn/Module.hs30
-rw-r--r--src/Language/PureScript/CoreFn/Traversals.hs85
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs131
-rw-r--r--src/Language/PureScript/Environment.hs25
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs3
-rw-r--r--src/Language/PureScript/Names.hs4
-rw-r--r--src/Language/PureScript/Parser.hs1
-rw-r--r--src/Language/PureScript/Parser/Common.hs311
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs258
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs18
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs491
-rw-r--r--src/Language/PureScript/Parser/Types.hs52
-rw-r--r--src/Language/PureScript/Pretty/Common.hs2
-rw-r--r--src/Language/PureScript/Pretty/JS.hs43
-rw-r--r--src/Language/PureScript/Pretty/Values.hs8
-rw-r--r--src/Language/PureScript/Renamer.hs133
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs12
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs14
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs6
-rw-r--r--src/Language/PureScript/Sugar/Names.hs26
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs2
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs87
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs8
-rw-r--r--src/Language/PureScript/TypeChecker.hs32
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs10
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs2
-rw-r--r--src/Language/PureScript/Types.hs15
68 files changed, 2416 insertions, 1299 deletions
diff --git a/examples/failing/Eff.purs b/examples/failing/Eff.purs
new file mode 100644
index 0000000..6fb7174
--- /dev/null
+++ b/examples/failing/Eff.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.ST
+import Debug.Trace
+
+test = pureST (do
+ ref <- newSTRef 0
+ trace "ST"
+ modifySTRef ref $ \n -> n + 1
+ readSTRef ref)
diff --git a/examples/failing/UnderscoreModuleName.purs b/examples/failing/UnderscoreModuleName.purs
new file mode 100644
index 0000000..508e48a
--- /dev/null
+++ b/examples/failing/UnderscoreModuleName.purs
@@ -0,0 +1,3 @@
+module Bad_Module where
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/CaseInDo.purs b/examples/passing/CaseInDo.purs
new file mode 100644
index 0000000..a5a118c
--- /dev/null
+++ b/examples/passing/CaseInDo.purs
@@ -0,0 +1,20 @@
+module Main where
+
+import Debug.Trace
+import Control.Monad.Eff
+
+foreign import doIt "function doIt() { global.flag = true; }" :: forall eff. Eff eff Unit
+
+foreign import get "function get() { return global.flag; }" :: forall eff. Eff eff Boolean
+
+set = do
+ trace "Testing..."
+ case 0 of
+ 0 -> doIt
+ _ -> return unit
+
+main = do
+ set
+ b <- get
+ case b of
+ true -> trace "Done"
diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs
index f64bb86..0fb8494 100644
--- a/examples/passing/Eff.purs
+++ b/examples/passing/Eff.purs
@@ -14,6 +14,12 @@ test2 = runPure (runST (do
modifySTRef ref $ \n -> n + 1
readSTRef ref))
+test3 = pureST (do
+ ref <- newSTRef 0
+ modifySTRef ref $ \n -> n + 1
+ readSTRef ref)
+
main = do
test1
Debug.Trace.print test2
+ Debug.Trace.print test3
diff --git a/examples/passing/ForeignInstance.purs b/examples/passing/ForeignInstance.purs
index 325ad37..1c32105 100644
--- a/examples/passing/ForeignInstance.purs
+++ b/examples/passing/ForeignInstance.purs
@@ -9,6 +9,10 @@ foreign import instance fooNumber :: Foo Number
foreign import instance fooString :: Foo String
+foreign import fooString "var fooString = {};" :: Unit
+foreign import fooNumber "var fooNumber = {};" :: Unit
+foreign import fooArray "var fooArray = {};" :: Unit
+
test1 _ = foo [1, 2, 3]
test2 _ = foo "Test"
diff --git a/examples/passing/Objects.purs b/examples/passing/Objects.purs
index 3f56969..26ab1a9 100644
--- a/examples/passing/Objects.purs
+++ b/examples/passing/Objects.purs
@@ -26,5 +26,10 @@ module Main where
test5 = case { "***": 1 } of
{ "***" = n } -> n
+
+ test6 = case { "***": 1 } of
+ { "***": n } -> n
+
+ test7 {a: snoog , b : blah } = blah
main = Debug.Trace.trace "Done"
diff --git a/examples/passing/TypeWildcardsRecordExtension.purs b/examples/passing/TypeWildcardsRecordExtension.purs
new file mode 100644
index 0000000..ea6c01a
--- /dev/null
+++ b/examples/passing/TypeWildcardsRecordExtension.purs
@@ -0,0 +1,6 @@
+module Main where
+
+foo :: forall a. {b :: Number | a} -> {b :: Number | _}
+foo f = f
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/UnderscoreIdent.purs b/examples/passing/UnderscoreIdent.purs
new file mode 100644
index 0000000..0bdfb08
--- /dev/null
+++ b/examples/passing/UnderscoreIdent.purs
@@ -0,0 +1,9 @@
+module Main where
+
+data Data_type = Con_Structor | Con_2 String
+
+type Type_name = Data_type
+
+done (Con_2 s) = s
+
+main = Debug.Trace.trace (done (Con_2 "Done"))
diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs
index b60cf16..bdb14a0 100644
--- a/hierarchy/Main.hs
+++ b/hierarchy/Main.hs
@@ -55,9 +55,9 @@ runModuleName :: P.ModuleName -> String
runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
readInput :: FilePath -> IO (Either Par.ParseError [P.Module])
-readInput p = do
- text <- U.readFile p
- return $ P.runIndentParser p P.parseModules text
+readInput filename = do
+ content <- U.readFile filename
+ return $ fmap (map snd) $ P.parseModulesFromFiles id [(filename, content)]
compile :: HierarchyOptions -> IO ()
compile (HierarchyOptions input mOutput) = do
@@ -84,7 +84,7 @@ superClasses :: P.Declaration -> [SuperMap]
superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =
fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers
superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]
-superClasses (P.PositionedDeclaration _ decl) = superClasses decl
+superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl
superClasses _ = []
inputFile :: Parser FilePath
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 85b8a00..c84dd8d 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -915,3 +915,5 @@ module Control.Monad.ST where
\ return f;\
\}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
+ pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
+ pureST st = runPure (runST st)
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index d40ea17..cf4d191 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -75,8 +75,8 @@ renderModules showHierarchy ms = do
mapM_ (renderModule showHierarchy) ms
renderModule :: Bool -> P.Module -> Docs
-renderModule showHierarchy (P.Module moduleName ds exps) =
- let exported = filter (isExported exps) ds
+renderModule showHierarchy mdl@(P.Module moduleName _ exps) =
+ let ds = P.exportedDeclarations mdl
hasTypes = any isTypeDeclaration ds
hasTypeclasses = any isTypeClassDeclaration ds
hasTypeclassInstances = any isTypeInstanceDeclaration ds
@@ -87,7 +87,7 @@ renderModule showHierarchy (P.Module moduleName ds exps) =
when hasTypes $ do
headerLevel 3 "Types"
spacer
- renderTopLevel exps (filter isTypeDeclaration exported)
+ renderTopLevel exps (filter isTypeDeclaration ds)
spacer
when hasTypeclasses $ do
headerLevel 3 "Type Classes"
@@ -95,7 +95,7 @@ renderModule showHierarchy (P.Module moduleName ds exps) =
when showHierarchy $ do
renderTypeclassImage moduleName
spacer
- renderTopLevel exps (filter isTypeClassDeclaration exported)
+ renderTopLevel exps (filter isTypeClassDeclaration ds)
spacer
when hasTypeclassInstances $ do
headerLevel 3 "Type Class Instances"
@@ -105,34 +105,9 @@ renderModule showHierarchy (P.Module moduleName ds exps) =
when hasValues $ do
headerLevel 3 "Values"
spacer
- renderTopLevel exps (filter isValueDeclaration exported)
+ renderTopLevel exps (filter isValueDeclaration ds)
spacer
-isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool
-isExported Nothing _ = True
-isExported _ P.TypeInstanceDeclaration{} = True
-isExported exps (P.PositionedDeclaration _ d) = isExported exps d
-isExported (Just exps) decl = any (matches decl) exps
- where
- matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'
- matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'
- matches (P.DataDeclaration _ ident _ _) (P.TypeRef ident' _) = ident == ident'
- matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'
- matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
- matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'
- matches (P.PositionedDeclaration _ d) r = d `matches` r
- matches d (P.PositionedDeclarationRef _ r) = d `matches` r
- matches _ _ = False
-
-isDctorExported :: P.ProperName -> Maybe [P.DeclarationRef] -> P.ProperName -> Bool
-isDctorExported _ Nothing _ = True
-isDctorExported ident (Just exps) ctor = test `any` exps
- where
- test (P.PositionedDeclarationRef _ d) = test d
- test (P.TypeRef ident' Nothing) = ident == ident'
- test (P.TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
- test _ = False
-
renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
renderDeclaration 4 exps decl
@@ -152,7 +127,7 @@ renderDeclaration n 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 (isDctorExported name exps . fst) ctors
+ exported = filter (P.isDctorExported name exps . fst) ctors
atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")
forM_ exported $ \(ctor, tys) ->
let ctorTy = foldr P.function typeApp tys
@@ -177,10 +152,20 @@ renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys
[] -> ""
cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
-renderDeclaration n exps (P.PositionedDeclaration _ d) =
+renderDeclaration n exps (P.PositionedDeclaration _ com d) = do
+ renderComments n com
+ spacer
renderDeclaration n exps d
renderDeclaration _ _ _ = return ()
+renderComments :: Int -> [P.Comment] -> Docs
+renderComments n cs = mapM_ (atIndent n) ls
+ where
+ ls = concatMap toLines cs
+
+ toLines (P.LineComment s) = [s]
+ toLines (P.BlockComment s) = lines s
+
toTypeVar :: (String, Maybe P.Kind) -> P.Type
toTypeVar (s, Nothing) = P.TypeVar s
toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
@@ -201,30 +186,30 @@ getName (P.ExternDataDeclaration name _) = P.runProperName name
getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
-getName (P.PositionedDeclaration _ d) = getName d
+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 (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 (P.PositionedDeclaration _ _ d) = isTypeDeclaration d
isTypeDeclaration _ = False
isTypeClassDeclaration :: P.Declaration -> Bool
isTypeClassDeclaration P.TypeClassDeclaration{} = True
-isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d
+isTypeClassDeclaration (P.PositionedDeclaration _ _ d) = isTypeClassDeclaration d
isTypeClassDeclaration _ = False
isTypeInstanceDeclaration :: P.Declaration -> Bool
isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True
-isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d
+isTypeInstanceDeclaration (P.PositionedDeclaration _ _ d) = isTypeInstanceDeclaration d
isTypeInstanceDeclaration _ = False
inputFile :: Parser FilePath
@@ -244,8 +229,10 @@ pscDocsOptions = PSCDocsOptions <$> includeHeirarcy
main :: IO ()
main = execParser opts >>= docgen
where
- opts = info (helper <*> pscDocsOptions) infoModList
+ opts = info (version <*> helper <*> pscDocsOptions) infoModList
infoModList = fullDesc <> headerInfo <> footerInfo
headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"
footerInfo = footer $ "psc-docs " ++ showVersion Paths.version
-
+
+ version :: Parser (a -> a)
+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index eddbb4a..fabc599 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -162,8 +162,10 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile
main :: IO ()
main = execParser opts >>= compile
where
- opts = info (helper <*> pscMakeOptions) infoModList
+ opts = info (version <*> helper <*> pscMakeOptions) infoModList
infoModList = fullDesc <> headerInfo <> footerInfo
headerInfo = header "psc-make - Compiles PureScript to Javascript"
footerInfo = footer $ "psc-make " ++ showVersion Paths.version
-
+
+ version :: Parser (a -> a)
+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
diff --git a/psc/Main.hs b/psc/Main.hs
index f1e2ee4..cee1052 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -192,8 +192,11 @@ pscOptions = PSCOptions <$> many inputFile
main :: IO ()
main = execParser opts >>= compile
where
- opts = info (helper <*> pscOptions) infoModList
+ opts = info (version <*> helper <*> pscOptions) infoModList
infoModList = fullDesc <> headerInfo <> footerInfo
headerInfo = header "psc - Compiles PureScript to Javascript"
footerInfo = footer $ "psc " ++ showVersion Paths.version
+
+ version :: Parser (a -> a)
+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
diff --git a/psci/Commands.hs b/psci/Commands.hs
index 67c6785..8f30b89 100644
--- a/psci/Commands.hs
+++ b/psci/Commands.hs
@@ -69,16 +69,19 @@ data Command
-- |
-- The help menu.
--
-help :: [[String]]
+help :: [(String, String, String)]
help =
- [ [":? ", "Show this help menu"]
- , [":i <module> ", "Import <module> for use in PSCI"]
- , [":b <module> ", "Browse <module>"]
- , [":m <file> ", "Load <file> for importing"]
- , [":q ", "Quit PSCi"]
- , [":r ", "Reset"]
- , [":s import ", "Show imported modules"]
- , [":s loaded ", "Show loaded modules"]
- , [":t <expr> ", "Show the type of <expr>"]
- , [":k <type> ", "Show the kind of <type>"]
+ [ (":?", "", "Show this help menu")
+ , (":i", "<module>", "Import <module> for use in PSCI")
+ , (":b", "<module>", "Browse <module>")
+ , (":m", "<file>", "Load <file> for importing")
+ , (":q", "", "Quit PSCi")
+ , (":r", "", "Reset")
+ , (":s", "import", "Show imported modules")
+ , (":s", "loaded", "Show loaded modules")
+ , (":t", "<expr>", "Show the type of <expr>")
+ , (":k", "<type>", "Show the kind of <type>")
]
+
+commands :: [String]
+commands = map (\ (a, _, _) -> a) help
diff --git a/psci/Main.hs b/psci/Main.hs
index 2206257..d09e504 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -22,6 +22,7 @@ import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)
import Data.Maybe (mapMaybe)
import Data.Traversable (traverse)
import Data.Version (showVersion)
+import Data.Char (isSpace)
import qualified Data.Map as M
import Control.Applicative
@@ -127,7 +128,9 @@ getHistoryFilename = do
-- Loads a file for use with imports.
--
loadModule :: FilePath -> IO (Either String [P.Module])
-loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename
+loadModule filename = do
+ content <- U.readFile filename
+ return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
-- |
-- Load all modules, including the Prelude
@@ -153,7 +156,9 @@ expandTilde p = return p
--
helpMessage :: String
helpMessage = "The following commands are available:\n\n " ++
- intercalate "\n " (map (intercalate " ") C.help)
+ intercalate "\n " (map line C.help)
+ where line :: (String, String, String) -> String
+ line (cmd, arg, desc) = intercalate " " [cmd, arg, replicate (11 - length arg) ' ', desc]
-- |
-- The welcome prologue.
@@ -180,37 +185,120 @@ quitMessage = "See ya!"
-- Haskeline completions
+data CompletionContext = Command String | FilePath String | Module | Identifier
+ | Type | Fixed [String] | Multiple [CompletionContext]
+ deriving (Show)
+
+-- |
+-- Decide what kind of completion we need based on input.
+completionContext :: String -> String -> Maybe CompletionContext
+completionContext cmd@"" _ = Just $ Multiple [Command cmd, Identifier]
+completionContext cmd@(':' : _ ) _
+ | cmd `elem` C.commands || cmd == ":" = Just $ Command cmd
+completionContext (':' : c : _) word = case c of
+ 'i' -> Just Module
+ 'b' -> Just Module
+ 'm' -> Just $ FilePath word
+ 'q' -> Nothing
+ 'r' -> Nothing
+ '?' -> Nothing
+ 's' -> Just $ Fixed ["import", "loaded"]
+ 't' -> Just Identifier
+ 'k' -> Just Type
+ _ -> Nothing
+completionContext _ _ = Just Identifier
+
-- |
-- Loads module, function, and file completions.
--
completion :: CompletionFunc (StateT PSCiState IO)
-completion = completeWord Nothing " \t\n\r" findCompletions
+completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
where
- findCompletions :: String -> StateT PSCiState IO [Completion]
- findCompletions st = do
- ms <- map snd . psciLoadedModules <$> get
- files <- listFiles st
- let matches = filter (isPrefixOf st) (names ms)
- return $ sortBy sorter $ map simpleCompletion matches ++ files
- getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
- getDeclName Nothing (P.ValueDeclaration ident _ _ _) = Just ident
- getDeclName (Just exts) (P.ValueDeclaration ident _ _ _) | isExported = Just ident
- where
- isExported = any exports exts
- exports (P.ValueRef ident') = ident == ident'
- exports (P.PositionedDeclarationRef _ r) = exports r
- exports _ = False
- getDeclName exts (P.PositionedDeclaration _ d) = getDeclName exts d
- getDeclName _ _ = Nothing
- names :: [P.Module] -> [String]
- names ms = nub [ show qual
- | P.Module moduleName ds exts <- ms
- , ident <- mapMaybe (getDeclName exts) ds
- , qual <- [ P.Qualified Nothing ident
- , P.Qualified (Just moduleName) ident]
- ]
+ findCompletions :: String -> String -> StateT PSCiState IO [Completion]
+ findCompletions prev word = do
+ let ctx = completionContext ((dropWhile isSpace (reverse prev)) ++ word) word
+ completions <- case ctx of
+ Nothing -> return []
+ (Just c) -> (mapMaybe $ either (\cand -> if word `isPrefixOf` cand
+ then Just $ simpleCompletion cand
+ else Nothing) Just)
+ <$> getCompletion c
+ return $ sortBy sorter completions
+
+ getCompletion :: CompletionContext -> StateT PSCiState IO [Either String Completion]
+ getCompletion (Command s) = return $ (map Left) $ nub $ filter (isPrefixOf s) C.commands
+ getCompletion (FilePath f) = (map Right) <$> listFiles f
+ getCompletion Module = (map Left) <$> getModuleNames
+ getCompletion Identifier = (map Left) <$> ((++) <$> getIdentNames <*> getDctorNames)
+ getCompletion Type = (map Left) <$> getTypeNames
+ getCompletion (Fixed list) = return $ (map Left) list
+ getCompletion (Multiple contexts) = concat <$> mapM getCompletion contexts
+
+ getLoadedModules :: StateT PSCiState IO [P.Module]
+ getLoadedModules = map snd . psciLoadedModules <$> get
+
+ getModuleNames :: StateT PSCiState IO [String]
+ getModuleNames = moduleNames <$> getLoadedModules
+
+ mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [a]) -> StateT PSCiState IO [String]
+ mapLoadedModulesAndQualify f = do
+ ms <- getLoadedModules
+ q <- sequence [qualifyIfNeeded m (f m) | m <- ms]
+ return $ concat q
+
+ getIdentNames :: StateT PSCiState IO [String]
+ getIdentNames = mapLoadedModulesAndQualify identNames
+
+ getDctorNames :: StateT PSCiState IO [String]
+ getDctorNames = mapLoadedModulesAndQualify dctorNames
+
+ getTypeNames :: StateT PSCiState IO [String]
+ getTypeNames = mapLoadedModulesAndQualify typeDecls
+
+ qualifyIfNeeded :: (Show a) => P.Module -> [a] -> StateT PSCiState IO [String]
+ qualifyIfNeeded m decls = do
+ let name = P.getModuleName m
+ imported <- psciImportedModuleNames <$> get
+ let qualified = map (P.Qualified $ Just name) decls
+ if name `elem` imported then
+ return $ map show $ qualified ++ (map (P.Qualified Nothing) decls)
+ else
+ return $ map show qualified
+
+ typeDecls :: P.Module -> [N.ProperName]
+ typeDecls m = mapMaybe getTypeName $ filter P.isDataDecl (P.exportedDeclarations m)
+ where getTypeName :: P.Declaration -> Maybe N.ProperName
+ getTypeName (P.TypeSynonymDeclaration name _ _) = Just name
+ getTypeName (P.DataDeclaration _ name _ _) = Just name
+ getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
+ getTypeName _ = Nothing
+
+ identNames :: P.Module -> [N.Ident]
+ identNames (P.Module _ ds exports) = nub [ ident | ident <- mapMaybe (getDeclName exports) (D.flattenDecls ds) ]
+ where getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
+ getDeclName exts decl@(P.ValueDeclaration ident _ _ _) | P.isExported exts decl = Just ident
+ getDeclName exts decl@(P.ExternDeclaration _ ident _ _) | P.isExported exts decl = Just ident
+ getDeclName exts (P.PositionedDeclaration _ _ d) = getDeclName exts d
+ getDeclName _ _ = Nothing
+
+ dctorNames :: P.Module -> [N.ProperName]
+ dctorNames m = nub $ concat $ map (P.exportedDctors m) dnames
+ where getDataDeclName :: P.Declaration -> Maybe N.ProperName
+ getDataDeclName (P.DataDeclaration _ name _ _) = Just name
+ getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d
+ getDataDeclName _ = Nothing
+
+ dnames :: [N.ProperName]
+ dnames = (mapMaybe getDataDeclName onlyDataDecls)
+
+ onlyDataDecls :: [P.Declaration]
+ onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))
+
+ moduleNames :: [P.Module] -> [String]
+ moduleNames ms = nub [show moduleName | P.Module moduleName _ _ <- ms]
+
sorter :: Completion -> Completion -> Ordering
- sorter (Completion _ d1 _) (Completion _ d2 _) = compare d1 d2
+ sorter (Completion _ d1 _) (Completion _ d2 _) = if ":" `isPrefixOf` d1 then LT else compare d1 d2
-- Compilation
@@ -441,7 +529,7 @@ handleKindOf typ = do
-- |
-- Parses the input and returns either a Metacommand or an expression.
--
-getCommand :: Bool -> InputT (StateT PSCiState IO) (Either Par.ParseError (Maybe Command))
+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
getCommand singleLineMode = do
firstLine <- getInputLine "> "
case firstLine of
@@ -519,7 +607,7 @@ loop (PSCiOptions singleLineMode files) = do
go = do
c <- getCommand singleLineMode
case c of
- Left err -> outputStrLn (show err) >> go
+ Left err -> outputStrLn err >> go
Right Nothing -> go
Right (Just Quit) -> outputStrLn quitMessage
Right (Just c') -> runPSCI (handleCommand c') >> go
@@ -541,8 +629,10 @@ psciOptions = PSCiOptions <$> singleLineFlag
main :: IO ()
main = execParser opts >>= loop
where
- opts = info (helper <*> psciOptions) infoModList
+ opts = info (version <*> helper <*> psciOptions) infoModList
infoModList = fullDesc <> headerInfo <> footerInfo
headerInfo = header "psci - Interactive mode for PureScript"
footerInfo = footer $ "psci " ++ showVersion Paths.version
+ version :: Parser (a -> a)
+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
diff --git a/psci/Parser.hs b/psci/Parser.hs
index 9fe45cc..6fb4dbe 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -17,6 +17,8 @@ module Parser (
parseCommand
) where
+import Prelude hiding (lex)
+
import Commands
import Data.Char (isSpace)
@@ -29,84 +31,52 @@ import qualified Language.PureScript as P
import qualified Language.PureScript.Parser.Common as C (mark, same)
-- |
--- PSCI version of @let@.
--- This is essentially let from do-notation.
--- However, since we don't support the @Eff@ monad,
--- we actually want the normal @let@.
---
-psciLet :: Parsec String P.ParseState Command
-psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> C.mark (many1 (C.same *> P.parseDeclaration))))
-
--- |
-- Parses PSCI metacommands or expressions input from the user.
--
-parseCommand :: String -> Either ParseError Command
-parseCommand = P.runIndentParser "" $ choice
- [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf <|> psciBrowse <|> psciShowModules)
- , try psciLet
- , psciExpression
- ] <* eof
-
--- |
--- Parses expressions entered at the PSCI repl.
---
-psciExpression :: Parsec String P.ParseState Command
-psciExpression = Expression <$> P.parseValue
-
--- |
--- Parses 'Commands.Help' command.
---
-psciHelp :: Parsec String P.ParseState Command
-psciHelp = Help <$ char '?'
-
--- |
--- Parses 'Commands.Import' command.
---
-psciImport :: Parsec String P.ParseState Command
-psciImport = Import <$> (char 'i' *> P.whiteSpace *> P.moduleName)
-
--- |
--- Parses 'Commands.LoadFile' command.
---
-psciLoadFile :: Parsec String P.ParseState Command
-psciLoadFile = LoadFile . trimEnd <$> (char 'm' *> P.whiteSpace *> manyTill anyChar eof)
-
--- | Trim end of input string
-trimEnd :: String -> String
-trimEnd = reverse . dropWhile isSpace . reverse
-
--- |
--- Parses 'Commands.Quit' command.
---
-psciQuit :: Parsec String P.ParseState Command
-psciQuit = Quit <$ char 'q'
-
--- |
--- Parses 'Commands.Reload' command.
---
-psciReload :: Parsec String P.ParseState Command
-psciReload = Reset <$ char 'r'
-
--- |
--- Parses 'Commands.TypeOf' command.
---
-psciTypeOf :: Parsec String P.ParseState Command
-psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue)
-
-
--- |
--- Parses 'Commands.KindOf' command.
---
-psciKindOf :: Parsec String P.ParseState Command
-psciKindOf = KindOf <$> (char 'k' *> P.whiteSpace *> P.parseType)
-
--- |
--- Parses 'Commands.Browse' command.
---
-psciBrowse :: Parsec String P.ParseState Command
-psciBrowse = Browse <$> (char 'b' *> P.whiteSpace *> P.moduleName)
-
--- |
--- Show Command
-psciShowModules :: Parsec String P.ParseState Command
-psciShowModules = Show . trimEnd <$> (char 's' *> P.whiteSpace *> manyTill anyChar eof)
+parseCommand :: String -> Either String Command
+parseCommand cmdString =
+ case splitCommand cmdString of
+ Just ('?', _) -> return Help
+ Just ('q', _) -> return Quit
+ Just ('r', _) -> return Reset
+ Just ('i', moduleName) -> Import <$> parseRest P.moduleName moduleName
+ Just ('b', moduleName) -> Browse <$> parseRest P.moduleName moduleName
+ Just ('m', filename) -> return $ LoadFile (trimEnd filename)
+ Just ('s', command) -> return $ Show (trimEnd command)
+ Just ('t', expr) -> TypeOf <$> parseRest P.parseValue expr
+ Just ('k', ty) -> KindOf <$> parseRest P.parseType ty
+ Just _ -> Left $ "Unrecognized command. Type :? for help."
+ Nothing -> parseRest (psciLet <|> psciExpression) cmdString
+ where
+ parseRest :: P.TokenParser a -> String -> Either String a
+ parseRest p s = either (Left . show) Right $ do
+ ts <- P.lex "" s
+ P.runTokenParser "" (p <* eof) ts
+
+ trimEnd :: String -> String
+ trimEnd = reverse . dropWhile isSpace . reverse
+
+ -- |
+ -- Split a command into a command char and the trailing string
+ --
+ splitCommand :: String -> Maybe (Char, String)
+ splitCommand (':' : c : s) = Just (c, dropWhile isSpace s)
+ splitCommand _ = Nothing
+
+ -- |
+ -- Parses expressions entered at the PSCI repl.
+ --
+ psciExpression :: P.TokenParser Command
+ psciExpression = Expression <$> P.parseValue
+
+ -- |
+ -- PSCI version of @let@.
+ -- This is essentially let from do-notation.
+ -- However, since we don't support the @Eff@ monad,
+ -- we actually want the normal @let@.
+ --
+ psciLet :: P.TokenParser Command
+ psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> manyDecls))
+ where
+ manyDecls :: P.TokenParser [P.Declaration]
+ manyDecls = C.mark (many1 (C.same *> P.parseDeclaration))
diff --git a/purescript.cabal b/purescript.cabal
index 2cfb3d9..9dc7d99 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.6.2
+version: 0.6.3
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -45,26 +45,37 @@ library
Language.PureScript.AST.SourcePos
Language.PureScript.AST.Traversals
Language.PureScript.CodeGen
- Language.PureScript.CodeGen.Common
Language.PureScript.CodeGen.Externs
Language.PureScript.CodeGen.JS
Language.PureScript.CodeGen.JS.AST
+ Language.PureScript.CodeGen.JS.Common
+ Language.PureScript.CodeGen.JS.Optimizer
+ Language.PureScript.CodeGen.JS.Optimizer.Blocks
+ Language.PureScript.CodeGen.JS.Optimizer.Common
+ Language.PureScript.CodeGen.JS.Optimizer.Inliner
+ Language.PureScript.CodeGen.JS.Optimizer.MagicDo
+ Language.PureScript.CodeGen.JS.Optimizer.TCO
+ Language.PureScript.CodeGen.JS.Optimizer.Unused
Language.PureScript.Constants
+ Language.PureScript.CoreFn
+ Language.PureScript.CoreFn.Ann
+ Language.PureScript.CoreFn.Binders
+ Language.PureScript.CoreFn.Desugar
+ Language.PureScript.CoreFn.Expr
+ Language.PureScript.CoreFn.Literals
+ Language.PureScript.CoreFn.Meta
+ Language.PureScript.CoreFn.Module
+ Language.PureScript.CoreFn.Traversals
+ Language.PureScript.Comments
Language.PureScript.DeadCodeElimination
Language.PureScript.Environment
Language.PureScript.Errors
Language.PureScript.Kinds
Language.PureScript.ModuleDependencies
Language.PureScript.Names
- Language.PureScript.Optimizer
- Language.PureScript.Optimizer.Blocks
- Language.PureScript.Optimizer.Common
- Language.PureScript.Optimizer.Inliner
- Language.PureScript.Optimizer.MagicDo
- Language.PureScript.Optimizer.TCO
- Language.PureScript.Optimizer.Unused
Language.PureScript.Options
Language.PureScript.Parser
+ Language.PureScript.Parser.Lexer
Language.PureScript.Parser.Common
Language.PureScript.Parser.Declarations
Language.PureScript.Parser.Kinds
@@ -103,58 +114,58 @@ library
buildable: True
hs-source-dirs: src
other-modules: Paths_purescript
- ghc-options: -Wall -O2
+ ghc-options: -Wall -fno-warn-warnings-deprecations -O2
executable psc
- build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
- mtl -any, optparse-applicative -any, parsec -any, purescript -any,
+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
+ mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
transformers -any, utf8-string -any
main-is: Main.hs
buildable: True
hs-source-dirs: psc
other-modules:
- ghc-options: -Wall -O2 -fno-warn-unused-do-bind
+ ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind
executable psc-make
- build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
- mtl -any, optparse-applicative -any, parsec -any, purescript -any,
+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
+ mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
transformers -any, utf8-string -any
main-is: Main.hs
buildable: True
hs-source-dirs: psc-make
other-modules:
- ghc-options: -Wall -O2 -fno-warn-unused-do-bind
+ ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind
executable psci
build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
- mtl -any, optparse-applicative -any, parsec -any,
- haskeline >= 0.7.0.0, purescript -any, transformers -any,
+ mtl -any, optparse-applicative >= 0.10.0, parsec -any,
+ haskeline >= 0.7.0.0, purescript -any, transformers -any,
utf8-string -any, process -any
-
+
main-is: Main.hs
buildable: True
hs-source-dirs: psci
other-modules: Commands
Parser
- ghc-options: -Wall -O2
+ ghc-options: -Wall -fno-warn-warnings-deprecations -O2
executable psc-docs
build-depends: base >=4 && <5, purescript -any, utf8-string -any,
- optparse-applicative -any, process -any, mtl -any
+ optparse-applicative >= 0.10.0, process -any, mtl -any
main-is: Main.hs
buildable: True
hs-source-dirs: psc-docs
other-modules:
- ghc-options: -Wall -O2
+ ghc-options: -Wall -fno-warn-warnings-deprecations -O2
executable hierarchy
- build-depends: base >=4 && <5, purescript -any, utf8-string -any, optparse-applicative -any,
+ build-depends: base >=4 && <5, purescript -any, utf8-string -any, optparse-applicative >= 0.10.0,
process -any, mtl -any, parsec -any, filepath -any, directory -any
main-is: Main.hs
buildable: True
hs-source-dirs: hierarchy
other-modules:
- ghc-options: -Wall -O2
+ ghc-options: -Wall -fno-warn-warnings-deprecations -O2
test-suite tests
build-depends: base >=4 && <5, containers -any, directory -any,
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 4a516d4..16f2189 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript
--- Copyright : (c) Phil Freeman 2013
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
-- License : MIT
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
@@ -17,42 +17,41 @@
module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where
-import Language.PureScript.Types as P
-import Language.PureScript.Kinds as P
+import Data.FileEmbed (embedFile)
+import Data.Function (on)
+import Data.List (sortBy, groupBy, intercalate)
+import Data.Maybe (fromMaybe)
+import Data.Time.Clock
+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 System.FilePath ((</>))
+
import Language.PureScript.AST as P
+import Language.PureScript.Comments as P
+import Language.PureScript.CodeGen as P
+import Language.PureScript.DeadCodeElimination as P
+import Language.PureScript.Environment as P
+import Language.PureScript.Errors as P
+import Language.PureScript.Kinds as P
+import Language.PureScript.ModuleDependencies as P
import Language.PureScript.Names as P
+import Language.PureScript.Options as P
import Language.PureScript.Parser as P
-import Language.PureScript.CodeGen as P
-import Language.PureScript.CodeGen.Common as P
-import Language.PureScript.TypeChecker as P
import Language.PureScript.Pretty as P
+import Language.PureScript.Renamer as P
import Language.PureScript.Sugar as P
-import Language.PureScript.Options as P
-import Language.PureScript.ModuleDependencies as P
-import Language.PureScript.Environment as P
-import Language.PureScript.Errors as P
-import Language.PureScript.DeadCodeElimination as P
import Language.PureScript.Supply as P
-import Language.PureScript.Renamer as P
-
+import Language.PureScript.TypeChecker as P
+import Language.PureScript.Types as P
+import qualified Language.PureScript.CoreFn as CoreFn
import qualified Language.PureScript.Constants as C
-import Data.List (sortBy, groupBy, intercalate)
-import Data.Time.Clock
-import Data.Function (on)
-import Data.Maybe (fromMaybe)
-import Data.FileEmbed (embedFile)
-
-import Control.Monad.Error
-import Control.Arrow ((&&&))
-import Control.Applicative
-
-import qualified Data.Map as M
-import qualified Data.Set as S
-import qualified Data.ByteString.UTF8 as BU
-
-import System.FilePath ((</>))
-
-- |
-- Compile a collection of modules
--
@@ -77,17 +76,18 @@ 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)
+ (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms
(desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
(elaborated, env') <- runCheck' opts 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 elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
+ let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
let renamed = renameInModules elim
let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)
- let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModuleNames) renamed
- let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs opts m env') modulesToCodeGen
- let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen
+ 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
+ let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
js' <- generateMain env' opts js
let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
return (pjs, exts, env')
@@ -156,7 +156,7 @@ make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options
make outputDir opts ms prefix = do
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) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else map (importPrelude . snd) ms
toRebuild <- foldM (\s (Module moduleName' _ _) -> do
let filePath = runModuleName moduleName'
@@ -199,11 +199,12 @@ make outputDir opts ms prefix = do
regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
let mod' = Module moduleName' regrouped exps
- let [renamed] = renameInModules [mod']
+ let corefn = CoreFn.moduleToCoreFn env' mod'
+ let [renamed] = renameInModules [corefn]
- pjs <- prettyPrintJS <$> moduleToJs opts renamed env'
+ pjs <- prettyPrintJS <$> moduleToJs opts renamed
let js = unlines $ map ("// " ++) prefix ++ [pjs]
- let exts = unlines $ map ("-- " ++ ) prefix ++ [moduleToPs renamed env']
+ let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
lift $ writeTextFile jsFile js
lift $ writeTextFile externsFile exts
@@ -219,7 +220,7 @@ 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 . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
+ externsModules <- liftError . fmap (map snd) . either (Left . show) Right $ 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"
@@ -239,7 +240,7 @@ addDefaultImport toImport m@(Module mn decls exps) =
else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps
where
isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
- isExistingImport (PositionedDeclaration _ d) = isExistingImport d
+ isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
isExistingImport _ = False
importPrim :: Module -> Module
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index dd06b45..d77ae96 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -20,6 +20,7 @@ import qualified Data.Data as D
import Language.PureScript.AST.SourcePos
import Language.PureScript.Names
+import Language.PureScript.Comments
-- |
-- Data type for binders
@@ -68,7 +69,7 @@ data Binder
-- |
-- A binder with source position information
--
- | PositionedBinder SourceSpan Binder deriving (Show, D.Data, D.Typeable)
+ | PositionedBinder SourceSpan [Comment] Binder deriving (Show, D.Data, D.Typeable)
-- |
-- Collect all names introduced in binders in an expression
@@ -82,5 +83,5 @@ binderNames = go []
go ns (ArrayBinder bs) = foldl go ns bs
go ns (ConsBinder b1 b2) = go (go ns b1) b2
go ns (NamedBinder name b) = go (name : ns) b
- go ns (PositionedBinder _ b) = go ns b
+ go ns (PositionedBinder _ _ b) = go ns b
go ns _ = ns
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 0266908..f02f22d 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -25,6 +25,7 @@ import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Kinds
import Language.PureScript.TypeClassDictionaries
+import Language.PureScript.Comments
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
@@ -34,6 +35,57 @@ import Language.PureScript.Environment
--
data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
+-- | Return a module's name.
+getModuleName :: Module -> ModuleName
+getModuleName (Module name _ _) = name
+
+-- |
+-- Test if a declaration is exported, given a module's export list.
+--
+isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
+isExported Nothing _ = True
+isExported _ TypeInstanceDeclaration{} = True
+isExported exps (PositionedDeclaration _ _ d) = isExported exps d
+isExported (Just exps) decl = any (matches decl) exps
+ where
+ matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
+ matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
+ matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'
+ matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
+ matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
+ matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
+ matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
+ matches (PositionedDeclaration _ _ d) r = d `matches` r
+ matches d (PositionedDeclarationRef _ _ r) = d `matches` r
+ matches _ _ = False
+
+exportedDeclarations :: Module -> [Declaration]
+exportedDeclarations (Module _ decls exps) = filter (isExported exps) (flattenDecls decls)
+
+-- |
+-- Test if a data constructor for a given type is exported, given a module's export list.
+--
+isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
+isDctorExported _ Nothing _ = True
+isDctorExported ident (Just exps) ctor = test `any` exps
+ where
+ test (PositionedDeclarationRef _ _ d) = test d
+ test (TypeRef ident' Nothing) = ident == ident'
+ test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
+ test _ = False
+
+-- |
+-- Return the exported data constructors for a given type.
+--
+exportedDctors :: Module -> ProperName -> [ProperName]
+exportedDctors (Module _ decls exps) ident =
+ filter (isDctorExported ident exps) dctors
+ where
+ dctors = concatMap getDctors (flattenDecls decls)
+ getDctors (DataDeclaration _ _ _ ctors) = map fst ctors
+ getDctors (PositionedDeclaration _ _ d) = getDctors d
+ getDctors _ = []
+
-- |
-- An item in a list of explicit imports or exports
--
@@ -57,7 +109,7 @@ data DeclarationRef
-- |
-- A declaration reference with source position information
--
- | PositionedDeclarationRef SourceSpan DeclarationRef
+ | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
deriving (Show, D.Data, D.Typeable)
instance Eq DeclarationRef where
@@ -65,8 +117,8 @@ instance Eq DeclarationRef where
(ValueRef name) == (ValueRef name') = name == name'
(TypeClassRef name) == (TypeClassRef name') = name == name'
(TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
- (PositionedDeclarationRef _ r) == r' = r == r'
- r == (PositionedDeclarationRef _ r') = r == r'
+ (PositionedDeclarationRef _ _ r) == r' = r == r'
+ r == (PositionedDeclarationRef _ _ r') = r == r'
_ == _ = False
-- |
@@ -126,7 +178,7 @@ data Declaration
-- |
-- A type class instance foreign import
--
- | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]
+ | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]
-- |
-- A fixity declaration (fixity data, operator name)
--
@@ -138,16 +190,16 @@ data Declaration
-- |
-- A type class declaration (name, argument, implies, member declarations)
--
- | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration]
+ | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]
-- |
-- A type instance declaration (name, dependencies, class name, instance types, member
-- declarations)
--
- | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
+ | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]
-- |
-- A declaration with source position information
--
- | PositionedDeclaration SourceSpan Declaration
+ | PositionedDeclaration SourceSpan [Comment] Declaration
deriving (Show, D.Data, D.Typeable)
-- |
@@ -155,7 +207,7 @@ data Declaration
--
isValueDecl :: Declaration -> Bool
isValueDecl ValueDeclaration{} = True
-isValueDecl (PositionedDeclaration _ d) = isValueDecl d
+isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d
isValueDecl _ = False
-- |
@@ -164,7 +216,7 @@ isValueDecl _ = False
isDataDecl :: Declaration -> Bool
isDataDecl DataDeclaration{} = True
isDataDecl TypeSynonymDeclaration{} = True
-isDataDecl (PositionedDeclaration _ d) = isDataDecl d
+isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d
isDataDecl _ = False
-- |
@@ -172,7 +224,7 @@ isDataDecl _ = False
--
isImportDecl :: Declaration -> Bool
isImportDecl ImportDeclaration{} = True
-isImportDecl (PositionedDeclaration _ d) = isImportDecl d
+isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d
isImportDecl _ = False
-- |
@@ -180,7 +232,7 @@ isImportDecl _ = False
--
isExternDataDecl :: Declaration -> Bool
isExternDataDecl ExternDataDeclaration{} = True
-isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d
+isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d
isExternDataDecl _ = False
-- |
@@ -188,7 +240,7 @@ isExternDataDecl _ = False
--
isExternInstanceDecl :: Declaration -> Bool
isExternInstanceDecl ExternInstanceDeclaration{} = True
-isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d
+isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d
isExternInstanceDecl _ = False
-- |
@@ -196,7 +248,7 @@ isExternInstanceDecl _ = False
--
isFixityDecl :: Declaration -> Bool
isFixityDecl FixityDeclaration{} = True
-isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d
+isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d
isFixityDecl _ = False
-- |
@@ -204,7 +256,7 @@ isFixityDecl _ = False
--
isExternDecl :: Declaration -> Bool
isExternDecl ExternDeclaration{} = True
-isExternDecl (PositionedDeclaration _ d) = isExternDecl d
+isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d
isExternDecl _ = False
-- |
@@ -213,10 +265,18 @@ isExternDecl _ = False
isTypeClassDeclaration :: Declaration -> Bool
isTypeClassDeclaration TypeClassDeclaration{} = True
isTypeClassDeclaration TypeInstanceDeclaration{} = True
-isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d
+isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d
isTypeClassDeclaration _ = False
-- |
+-- Recursively flatten data binding groups in the list of declarations
+flattenDecls :: [Declaration] -> [Declaration]
+flattenDecls = concatMap flattenOne
+ where flattenOne :: Declaration -> [Declaration]
+ flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
+ flattenOne d = [d]
+
+-- |
-- A guard is just a boolean-valued expression that appears alongside a set of binders
--
type Guard = Expr
@@ -316,7 +376,7 @@ data Expr
-- at superclass implementations when searching for a dictionary, the type class name and
-- instance type, and the type class dictionaries in scope.
--
- | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]
+ | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
-- |
-- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
--
@@ -324,7 +384,7 @@ data Expr
-- |
-- A value with source position information
--
- | PositionedValue SourceSpan Expr deriving (Show, D.Data, D.Typeable)
+ | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)
-- |
-- An alternative in a case statement
@@ -359,4 +419,4 @@ data DoNotationElement
-- |
-- A do notation element with source position information
--
- | PositionedDoNotationElement SourceSpan DoNotationElement deriving (Show, D.Data, D.Typeable)
+ | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, D.Data, D.Typeable)
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 1e4b868..9e81e3d 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -37,7 +37,7 @@ everywhereOnValues f g h = (f', g', h')
f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))
- f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))
+ f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))
f' other = f other
g' :: Expr -> Expr
@@ -56,7 +56,7 @@ everywhereOnValues f g h = (f', g', h')
g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)
g' (Let ds v) = g (Let (map f' ds) (g' v))
g' (Do es) = g (Do (map handleDoNotationElement es))
- g' (PositionedValue pos v) = g (PositionedValue pos (g' v))
+ g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v))
g' other = g other
h' :: Binder -> Binder
@@ -65,7 +65,7 @@ everywhereOnValues f g h = (f', g', h')
h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))
h' (NamedBinder name b) = h (NamedBinder name (h' b))
- h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))
+ h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
h' other = h other
handleCaseAlternative :: CaseAlternative -> CaseAlternative
@@ -78,7 +78,7 @@ everywhereOnValues f g h = (f', g', h')
handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)
handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)
handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
- handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)
+ handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
@@ -93,7 +93,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds
f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds
- f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f')
+ f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
f' other = f other
g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
@@ -111,7 +111,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty
g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')
g' (Do es) = Do <$> mapM handleDoNotationElement es
- g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g')
+ g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')
g' other = g other
h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs
@@ -119,7 +119,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs
h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')
h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
- h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')
+ h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
h' other = h other
handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs
@@ -128,7 +128,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds
- handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e
+ handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
(Declaration -> m Declaration) ->
@@ -142,7 +142,7 @@ everywhereOnValuesM f g h = (f', g', h')
f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f
f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f
- f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f
+ f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
f' other = f other
g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
@@ -160,7 +160,7 @@ everywhereOnValuesM f g h = (f', g', h')
g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g
g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g
g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g
- g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g
+ g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g
g' other = g other
h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h
@@ -168,7 +168,7 @@ everywhereOnValuesM f g h = (f', g', h')
h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h
h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h
h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
- h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h
+ h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
h' other = h other
handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs
@@ -177,7 +177,7 @@ everywhereOnValuesM f g h = (f', g', h')
handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds
- handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e
+ handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
everythingOnValues :: (r -> r -> r) ->
(Declaration -> r) ->
@@ -194,7 +194,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)
f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
- f' d@(PositionedDeclaration _ d1) = f d <> f' d1
+ f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
f' d = f d
g' v@(UnaryMinus v1) = g v <> g' v1
@@ -212,7 +212,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
g' v@(TypedValue _ v1 _) = g v <> g' v1
g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1
g' v@(Do es) = foldl (<>) (g v) (map j' es)
- g' v@(PositionedValue _ v1) = g v <> g' v1
+ g' v@(PositionedValue _ _ v1) = g v <> g' v1
g' v = g v
h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
@@ -220,7 +220,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2
h' b@(NamedBinder _ b1) = h b <> h' b1
- h' b@(PositionedBinder _ b1) = h b <> h' b1
+ h' b@(PositionedBinder _ _ b1) = h b <> h' b1
h' b = h b
i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
@@ -229,7 +229,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
j' e@(DoNotationValue v) = j e <> g' v
j' e@(DoNotationBind b v) = j e <> h' b <> g' v
j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
- j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1
+ j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1
everythingWithContextOnValues ::
s ->
@@ -255,7 +255,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
- f' s (PositionedDeclaration _ d1) = f'' s d1
+ f' s (PositionedDeclaration _ _ d1) = f'' s d1
f' _ _ = r0
g'' s v = let (s', r) = g s v in r <> g' s' v
@@ -275,7 +275,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
g' s (TypedValue _ v1 _) = g'' s v1
g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1
g' s (Do es) = foldl (<>) r0 (map (j'' s) es)
- g' s (PositionedValue _ v1) = g'' s v1
+ g' s (PositionedValue _ _ v1) = g'' s v1
g' _ _ = r0
h'' s b = let (s', r) = h s b in r <> h' s' b
@@ -285,7 +285,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
h' s (ConsBinder b1 b2) = h'' s b1 <> h'' s b2
h' s (NamedBinder _ b1) = h'' s b1
- h' s (PositionedBinder _ b1) = h'' s b1
+ h' s (PositionedBinder _ _ b1) = h'' s b1
h' _ _ = r0
i'' s ca = let (s', r) = i s ca in r <> i' s' ca
@@ -298,7 +298,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
j' s (DoNotationValue v) = g'' s v
j' s (DoNotationBind b v) = h'' s b <> g'' s v
j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
- j' s (PositionedDoNotationElement _ e1) = j'' s e1
+ j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
s ->
@@ -321,7 +321,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds
f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds
f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds
- f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1
+ f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1
f' _ other = return other
g'' s = uncurry g' <=< g s
@@ -341,7 +341,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty
g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v
g' s (Do es) = Do <$> mapM (j'' s) es
- g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v
+ g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v
g' _ other = return other
h'' s = uncurry h' <=< h s
@@ -351,7 +351,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs
h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2
h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
- h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b
+ h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
h' _ other = return other
i'' s = uncurry i' <=< i s
@@ -363,7 +363,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
j' s (DoNotationValue v) = DoNotationValue <$> g'' s v
j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v
j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds
- j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1
+ j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 8490730..0d9b6a5 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -17,21 +17,20 @@ module Language.PureScript.CodeGen.Externs (
moduleToPs
) where
-import Data.Maybe (fromMaybe, mapMaybe)
import Data.List (intercalate, find)
-
+import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Map as M
import Control.Monad.Writer
-import Language.PureScript.CodeGen.Common
-import Language.PureScript.TypeClassDictionaries
import Language.PureScript.AST
-import Language.PureScript.Pretty
-import Language.PureScript.Names
+import Language.PureScript.Environment
import Language.PureScript.Kinds
+import Language.PureScript.Names
+import Language.PureScript.Pretty
+import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
-import Language.PureScript.Environment
+import Language.PureScript.Comments
-- |
-- Generate foreign imports for all declarations in a module
@@ -48,11 +47,15 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
declToPs (FixityDeclaration (Fixity assoc prec) ident) =
tell [ unwords [ show assoc, show prec, ident ] ]
- declToPs (PositionedDeclaration _ d) = declToPs d
+ declToPs (PositionedDeclaration _ com d) = mapM commentToPs com >> declToPs d
declToPs _ = return ()
+
+ commentToPs :: Comment -> Writer [String] ()
+ commentToPs (LineComment s) = tell ["-- " ++ s]
+ commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]
exportToPs :: DeclarationRef -> Writer [String] ()
- exportToPs (PositionedDeclarationRef _ r) = exportToPs r
+ exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r
exportToPs (TypeRef pn dctors) = do
case Qualified (Just moduleName) pn `M.lookup` types env of
Nothing -> error $ show pn ++ " has no kind in exportToPs"
@@ -109,4 +112,3 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
isValueExported :: Ident -> Bool
isValueExported ident = ValueRef ident `elem` exts
-
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 2f8e966..56dd843 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -13,32 +13,28 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE GADTs, DoAndIfThenElse #-}
+{-# LANGUAGE GADTs, ViewPatterns #-}
module Language.PureScript.CodeGen.JS (
module AST,
- declToJs,
- moduleToJs,
- identNeedsEscaping
+ module Common,
+ bindToJs,
+ moduleToJs
) where
-import Data.Maybe (catMaybes)
-import Data.Function (on)
-import Data.List (nub, (\\), delete, sortBy)
+import Data.List ((\\), delete)
+import Data.Maybe (mapMaybe)
-import qualified Data.Map as M
-
-import Control.Monad (foldM, replicateM, forM)
import Control.Applicative
-import Control.Arrow (second)
+import Control.Arrow ((&&&))
+import Control.Monad (foldM, replicateM, forM)
+import Language.PureScript.CodeGen.JS.AST as AST
+import Language.PureScript.CodeGen.JS.Common as Common
+import Language.PureScript.CoreFn
import Language.PureScript.Names
-import Language.PureScript.AST
+import Language.PureScript.CodeGen.JS.Optimizer
import Language.PureScript.Options
-import Language.PureScript.CodeGen.JS.AST as AST
-import Language.PureScript.Optimizer
-import Language.PureScript.CodeGen.Common
-import Language.PureScript.Environment
import Language.PureScript.Supply
import Language.PureScript.Traversals (sndM)
import qualified Language.PureScript.Constants as C
@@ -47,25 +43,28 @@ 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 -> Environment -> SupplyT m [JS]
-moduleToJs opts (Module name decls (Just exps)) env = do
- let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls
- jsDecls <- mapM (\decl -> declToJs opts name decl env) decls
- let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
+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
+ let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
+ jsDecls <- mapM (bindToJs name) decls
+ let optimized = concatMap (map $ optimize opts) jsDecls
let isModuleEmpty = null exps
- let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
- let moduleExports = JSObjectLiteral . map (second var) . M.toList . M.unions $ map exportToJs exps
+ let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized
+ let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
return $ case optionsAdditional opts of
- MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
+ MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
CompileOptions ns _ _ | not isModuleEmpty ->
[ JSVariableIntroduction ns
(Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
, JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))
- (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
]
_ -> []
-moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"
+-- |
+-- Generates Javascript code for a module import.
+--
importToJs :: Options mode -> ModuleName -> JS
importToJs opts mn =
JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
@@ -74,95 +73,26 @@ importToJs opts mn =
MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
-imports :: Declaration -> [ModuleName]
-imports (ImportDeclaration mn _ _) = [mn]
-imports other =
- let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])
- in f other
- where
- collectV :: Expr -> [ModuleName]
- collectV (Var (Qualified (Just mn) _)) = [mn]
- collectV (Constructor (Qualified (Just mn) _)) = [mn]
- collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]
- collectV _ = []
- collectB :: Binder -> [ModuleName]
- collectB (ConstructorBinder (Qualified (Just mn) _) _) = [mn]
- collectB _ = []
-
-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
--
-declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
-declToJs opts mp (ValueDeclaration ident _ _ (Right val)) e = do
- js <- valueToJs opts mp e val
- return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
-declToJs opts mp (BindingGroupDeclaration vals) e = do
- jss <- forM vals $ \(ident, _, val) -> do
- js <- valueToJs opts mp e val
- return $ JSVariableIntroduction (identToJs ident) (Just js)
- return $ Just jss
-declToJs _ _ (DataDeclaration Newtype _ _ [((ProperName ctor), _)]) _ =
- return $ Just $ [JSVariableIntroduction ctor (Just $
- JSObjectLiteral [("create",
- JSFunction Nothing ["value"]
- (JSBlock [JSReturn $ JSVar "value"]))])]
-declToJs _ _ (DataDeclaration Newtype _ _ _) _ =
- error "newtype has multiple constructors"
-declToJs _ mp (DataDeclaration Data _ _ ctors) e = do
- return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
- let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"
- in [ makeConstructor ctor (length tys)
- , JSAssignment (JSAccessor propName (JSVar ctor)) (go pn 0 (length tys) [])
- ]
- 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 :: ProperName -> Int -> Int -> [JS] -> JS
- go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar $ runProperName 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))])
-declToJs opts mp (DataBindingGroupDeclaration ds) e = do
- jss <- mapM (\decl -> declToJs opts mp decl e) ds
- return $ Just $ concat $ catMaybes jss
-declToJs _ _ (TypeClassDeclaration name _ supers members) _ =
- return $ Just $ [
- JSFunction (Just $ runProperName name) (identToJs `map` args)
- (JSBlock $ assn `map` args)]
- where
- assn :: Ident -> JS
- assn arg = JSAssignment (accessor arg (JSVar "this")) (var arg)
- args :: [Ident]
- args = sortBy (compare `on` runIdent) $ memberNames ++ superNames
- memberNames :: [Ident]
- memberNames = memberToName `map` members
- superNames :: [Ident]
- superNames = [ toSuperName superclass index
- | (index, (superclass, _)) <- zip [0..] supers
- ]
- toSuperName :: Qualified ProperName -> Integer -> Ident
- toSuperName pn index = Ident $ C.__superclass_ ++ show pn ++ "_" ++ show index
- memberToName :: Declaration -> Ident
- memberToName (TypeDeclaration ident _) = ident
- memberToName (PositionedDeclaration _ d) = memberToName d
- memberToName _ = error "Invalid declaration in type class definition"
-declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
-declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
-declToJs _ _ _ _ = return Nothing
+bindToJs :: (Functor m, Applicative m, Monad 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))
-- |
--- Generate key//value pairs for an object literal exporting values from a module.
+-- Generate code in the simplified Javascript intermediate representation for a single non-recursive
+-- declaration.
+--
+-- The main purpose of this function is to handle code generation for comments.
--
-exportToJs :: DeclarationRef -> M.Map String Ident
-exportToJs (TypeRef _ (Just dctors)) = M.fromList [ (n, Ident n) | (ProperName n) <- dctors ]
-exportToJs (ValueRef name) = M.singleton (runIdent name) name
-exportToJs (TypeInstanceRef name) = M.singleton (runIdent name) name
-exportToJs (TypeClassRef name) = M.singleton (runProperName name) (Ident $ runProperName name)
-exportToJs _ = M.empty
+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 mp ident val = do
+ js <- valueToJs mp val
+ return $ JSVariableIntroduction (identToJs ident) (Just js)
+
-- |
-- Generate code in the simplified Javascript intermediate representation for a variable based on a
@@ -187,54 +117,89 @@ 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) => Options mode -> ModuleName -> Environment -> Expr -> SupplyT m JS
-valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
-valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
-valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
-valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs
-valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps
-valueToJs opts m e (TypeClassDictionaryConstructorApp name (TypedValue _ (ObjectLiteral ps) _)) =
- JSUnary JSNew . JSApp (qualifiedToJS m (Ident . runProperName) name) <$> mapM (valueToJs opts m e . snd) (sortBy (compare `on` fst) ps)
-valueToJs _ _ _ TypeClassDictionaryConstructorApp{} =
- error "TypeClassDictionaryConstructorApp did not contain object literal"
-valueToJs opts m e (ObjectUpdate o ps) = do
- obj <- valueToJs opts m e o
- sts <- mapM (sndM (valueToJs opts m e)) ps
+valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS
+valueToJs m (Literal _ l) =
+ literalToValueJS m l
+valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) =
+ return $ JSAccessor "value" $ qualifiedToJS m id name
+valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =
+ return $ JSAccessor "create" $ qualifiedToJS m id name
+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
extendObj obj sts
-valueToJs _ m e (Constructor name) =
- let propName = if isNullaryConstructor e name then "value" else "create"
- in return $ JSAccessor propName $ qualifiedToJS m (Ident . runProperName) name
-valueToJs opts m e (Case values binders) = do
- vals <- mapM (valueToJs opts m e) values
- bindersToJs opts m e binders vals
-valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
-valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
-valueToJs opts m e v@App{} = do
- let (f, args) = unApp v []
- args' <- mapM (valueToJs opts m e) args
+valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
+ let args = unAbs e
+ in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
+ where
+ unAbs :: Expr Ann -> [Ident]
+ unAbs (Abs _ arg val) = arg : unAbs val
+ unAbs _ = []
+ assign :: Ident -> JS
+ assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
+ (var name)
+valueToJs m (Abs _ arg val) = do
+ ret <- valueToJs m val
+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
+valueToJs m e@App{} = do
+ let (f, args) = unApp e []
+ args' <- mapM (valueToJs m) args
case f of
- Constructor name | isNewtypeConstructor e name && length args == 1 -> return (head args')
- Constructor name | getConstructorArity e name == length args ->
- return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'
- _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f
+ Var (_, _, _, Just IsNewtype) _ -> return (head args')
+ Var (_, _, _, Just (IsConstructor _ arity)) name | arity == length args ->
+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
+ Var (_, _, _, Just IsTypeClassConstructor) name ->
+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f
where
- unApp :: Expr -> [Expr] -> (Expr, [Expr])
- unApp (App val arg) args = unApp val (arg : args)
- unApp (PositionedValue _ val) args = unApp val args
- unApp (TypedValue _ val _) args = unApp val args
+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
+ unApp (App _ val arg) args = unApp val (arg : args)
unApp other args = (other, args)
-valueToJs opts m e (Let ds val) = do
- decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds
- ret <- valueToJs opts m e val
+valueToJs m (Var _ ident) =
+ return $ varToJs m ident
+valueToJs m (Case _ values binders) = do
+ vals <- mapM (valueToJs m) values
+ bindersToJs m binders vals
+valueToJs m (Let _ ds val) = do
+ decls <- concat <$> mapM (bindToJs m) ds
+ ret <- valueToJs m val
return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
-valueToJs opts m e (Abs (Left arg) val) = do
- ret <- valueToJs opts m e val
- return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
-valueToJs _ m _ (Var ident) = return $ varToJs m ident
-valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
-valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
-valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"
-valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
+valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
+ return $ JSVariableIntroduction ctor (Just $
+ JSObjectLiteral [("create",
+ JSFunction Nothing ["value"]
+ (JSBlock [JSReturn $ JSVar "value"]))])
+valueToJs _ (Constructor _ _ (ProperName ctor) 0) =
+ 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))])
+
+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 _ (NumericLiteral n) = return $ JSNumericLiteral n
+literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
+literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
+literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs
+literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps
-- |
-- Shallow copy an object.
@@ -276,109 +241,111 @@ 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) => Options mode -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
-bindersToJs opts m e binders vals = do
+bindersToJs :: (Functor m, Applicative m, Monad 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)
jss <- forM binders $ \(CaseAlternative bs result) -> do
ret <- guardsToJs result
go valNames ret bs
- return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [JSStringLiteral "Failed pattern match"]])))
+ 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] -> SupplyT m [JS]
+ go :: (Functor m, Applicative m, Monad 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 e v done'' b
+ binderToJs m v done'' b
go _ _ _ = error "Invalid arguments to bindersToJs"
- guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard, Expr)] Expr -> SupplyT m [JS]
+ guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]
guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
- cond' <- valueToJs opts m e cond
- done <- valueToJs opts m e val
+ cond' <- valueToJs m cond
+ done <- valueToJs m val
return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
- guardsToJs (Right v) = return . JSReturn <$> valueToJs opts m e v
+ guardsToJs (Right v) = return . JSReturn <$> valueToJs m v
-- |
-- Generate code in the simplified Javascript intermediate representation for a pattern match
-- binder.
--
-binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]
-binderToJs _ _ _ done NullBinder = return done
-binderToJs _ _ varName done (StringBinder str) =
- return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
-binderToJs _ _ varName done (NumberBinder num) =
- return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
-binderToJs _ _ varName done (BooleanBinder True) =
- return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
-binderToJs _ _ varName done (BooleanBinder False) =
- return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
-binderToJs _ _ varName done (VarBinder ident) =
+binderToJs :: (Functor m, Applicative m, Monad 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
+binderToJs _ varName done (VarBinder _ ident) =
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
-binderToJs m e varName done (ConstructorBinder ctor bs) | isNewtypeConstructor e ctor =
- case bs of
- [b] -> binderToJs m e varName done b
- _ -> error "binder for newtype constructor should have a single argument"
-binderToJs m e varName done (ConstructorBinder ctor bs) = do
+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
- if isOnlyConstructor e ctor
- then
- return js
- else
- return [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
- (JSBlock js)
- Nothing]
+ return $ case ctorType of
+ ProductType -> js
+ SumType ->
+ [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
+ (JSBlock js)
+ Nothing]
where
- go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]
+ go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]
go _ done' [] = return done'
go index done' (binder:bs') = do
argVar <- freshName
done'' <- go (index + 1) done' bs'
- js <- binderToJs m e argVar done'' binder
+ js <- binderToJs m argVar done'' binder
return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)
-binderToJs m e varName done (ObjectBinder bs) = go done bs
- where
- go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]
- go done' [] = return done'
- go done' ((prop, binder):bs') = do
- propVar <- freshName
- done'' <- go done' bs'
- js <- binderToJs m e propVar done'' binder
- return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
-binderToJs m e varName done (ArrayBinder 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] -> SupplyT m [JS]
- go done' _ [] = return done'
- go done' index (binder:bs') = do
- elVar <- freshName
- done'' <- go done' (index + 1) bs'
- js <- binderToJs m e elVar done'' binder
- return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
-binderToJs m e varName done binder@(ConsBinder _ _) = do
+binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
let (headBinders, tailBinder) = uncons [] binder
numberOfHeadBinders = fromIntegral $ length headBinders
js1 <- foldM (\done' (headBinder, index) -> do
headVar <- freshName
- jss <- binderToJs m e headVar done' headBinder
+ jss <- binderToJs m headVar done' headBinder
return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
tailVar <- freshName
- js2 <- binderToJs m e tailVar js1 tailBinder
+ js2 <- binderToJs m tailVar js1 tailBinder
return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
js2
)) Nothing]
where
- uncons :: [Binder] -> Binder -> ([Binder], Binder)
- uncons acc (ConsBinder h t) = uncons (h : acc) t
- uncons acc (PositionedBinder _ b) = uncons acc b
+ uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
+ uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
uncons acc tailBinder = (reverse acc, tailBinder)
-binderToJs m e varName done (NamedBinder ident binder) = do
- js <- binderToJs m e varName done binder
+binderToJs _ _ _ b@(ConstructorBinder{}) =
+ error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
+binderToJs m varName done (NamedBinder _ ident binder) = do
+ js <- binderToJs m varName done binder
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
-binderToJs m e varName done (PositionedBinder _ binder) =
- binderToJs m e varName done binder
+literalToBinderJS :: (Functor m, Applicative m, Monad 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) =
+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
+literalToBinderJS _ varName done (BooleanLiteral True) =
+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
+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 done' [] = return done'
+ go done' ((prop, binder):bs') = do
+ propVar <- freshName
+ done'' <- go done' bs'
+ js <- binderToJs m propVar done'' binder
+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
+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 done' _ [] = return done'
+ go done' index (binder:bs') = do
+ elVar <- freshName
+ done'' <- go done' (index + 1) bs'
+ js <- binderToJs m elVar done'' binder
+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
+isCons :: Qualified ProperName -> Bool
+isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
+isCons name = error $ "Unexpected argument in isCons: " ++ show name
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 4666ab0..1f3ce4c 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -19,6 +19,8 @@ module Language.PureScript.CodeGen.JS.AST where
import Data.Data
+import Language.PureScript.Comments
+
-- |
-- Built-in unary operators
--
@@ -240,7 +242,11 @@ data JS
-- |
-- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
--
- | JSRaw String deriving (Show, Eq, Data, Typeable)
+ | JSRaw String
+ -- |
+ -- Commented Javascript
+ --
+ | JSComment [Comment] JS deriving (Show, Eq, Data, Typeable)
--
-- Traversals
@@ -271,6 +277,7 @@ everywhereOnJS f = go
go (JSTypeOf js) = f (JSTypeOf (go js))
go (JSLabel name js) = f (JSLabel name (go js))
go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))
+ go (JSComment com j) = f (JSComment com (go j))
go other = f other
everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
@@ -298,6 +305,7 @@ everywhereOnJSTopDown f = go . f
go (JSTypeOf j) = JSTypeOf (go (f j))
go (JSLabel name j) = JSLabel name (go (f j))
go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))
+ go (JSComment com j) = JSComment com (go (f j))
go other = f other
everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
@@ -325,4 +333,5 @@ everythingOnJS (<>) f = go
go j@(JSTypeOf j1) = f j <> go j1
go j@(JSLabel _ j1) = f j <> go j1
go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2
+ go j@(JSComment _ j1) = f j <> go j1
go other = f other
diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs
index f8af6d8..8c90813 100644
--- a/src/Language/PureScript/CodeGen/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Common.hs
@@ -13,18 +13,12 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.CodeGen.Common where
+module Language.PureScript.CodeGen.JS.Common where
import Data.Char
import Data.List (intercalate)
-import Data.Maybe (fromMaybe)
-import Data.Function (on)
-
-import qualified Data.Map as M
import Language.PureScript.Names
-import Language.PureScript.Environment
-import Language.PureScript.Types
-- |
-- Convert an Ident into a valid Javascript identifier:
@@ -145,49 +139,3 @@ nameIsJsReserved name =
moduleNameToJs :: ModuleName -> String
moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
-
--- |
--- Finds the value stored for a data constructor in the current environment.
--- This is a partial function, but if an invalid type has reached this far then
--- something has gone wrong in typechecking.
---
-lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)
-lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e
-
--- |
--- Checks whether a data constructor is the only constructor for that type, used
--- to simplify the check when generating code for binders.
---
-isOnlyConstructor :: Environment -> Qualified ProperName -> Bool
-isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1
- where
- numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int
- numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e
- typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)
- typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)
- typeConstructor _ = error "Invalid argument to isOnlyConstructor"
-
--- |
--- Checks whether a data constructor is for a newtype.
---
-isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
-isNewtypeConstructor e ctor = case lookupConstructor e ctor of
- (Newtype, _, _) -> True
- (Data, _, _) -> False
-
--- |
--- Checks the number of arguments a data constructor accepts.
---
-getConstructorArity :: Environment -> Qualified ProperName -> Int
-getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e
- where
- go :: Type -> Int
- go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1
- go (ForAll _ ty _) = go ty
- go _ = 0
-
--- |
--- Checks whether a data constructor has no arguments, for example, `Nothing`.
---
-isNullaryConstructor :: Environment -> Qualified ProperName -> Bool
-isNullaryConstructor e = (== 0) . getConstructorArity e
diff --git a/src/Language/PureScript/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
index 3a42930..551e179 100644
--- a/src/Language/PureScript/Optimizer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Optimizer
+-- Module : Language.PureScript.CodeGen.JS.Optimizer
-- Copyright : (c) Phil Freeman 2013
-- License : MIT
--
@@ -31,7 +31,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.Optimizer (
+module Language.PureScript.CodeGen.JS.Optimizer (
optimize
) where
@@ -39,12 +39,12 @@ import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Options
import qualified Language.PureScript.Constants as C
-import Language.PureScript.Optimizer.Common
-import Language.PureScript.Optimizer.TCO
-import Language.PureScript.Optimizer.MagicDo
-import Language.PureScript.Optimizer.Inliner
-import Language.PureScript.Optimizer.Unused
-import Language.PureScript.Optimizer.Blocks
+import Language.PureScript.CodeGen.JS.Optimizer.Common
+import Language.PureScript.CodeGen.JS.Optimizer.TCO
+import Language.PureScript.CodeGen.JS.Optimizer.MagicDo
+import Language.PureScript.CodeGen.JS.Optimizer.Inliner
+import Language.PureScript.CodeGen.JS.Optimizer.Unused
+import Language.PureScript.CodeGen.JS.Optimizer.Blocks
-- |
-- Apply a series of optimizer passes to simplified Javascript code
diff --git a/src/Language/PureScript/Optimizer/Blocks.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs
index ef95141..68c29c7 100644
--- a/src/Language/PureScript/Optimizer/Blocks.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Optimizer.Blocks
+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Blocks
-- Copyright : (c) Phil Freeman 2013-14
-- License : MIT
--
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.Optimizer.Blocks
+module Language.PureScript.CodeGen.JS.Optimizer.Blocks
( collapseNestedBlocks
, collapseNestedIfs
) where
diff --git a/src/Language/PureScript/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
index aec728d..11b1cdf 100644
--- a/src/Language/PureScript/Optimizer/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Optimizer.Common
+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Common
-- Copyright : (c) Phil Freeman 2013-14
-- License : MIT
--
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.Optimizer.Common where
+module Language.PureScript.CodeGen.JS.Optimizer.Common where
import Data.Maybe (fromMaybe)
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index a5f1244..a4dc800 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Optimizer.Inliner
+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Inliner
-- Copyright : (c) Phil Freeman 2013-14
-- License : MIT
--
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.Optimizer.Inliner (
+module Language.PureScript.CodeGen.JS.Optimizer.Inliner (
inlineVariables,
inlineOperator,
inlineCommonOperators,
@@ -25,10 +25,9 @@ module Language.PureScript.Optimizer.Inliner (
import Data.Maybe (fromMaybe)
import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.CodeGen.Common (identToJs)
-import Language.PureScript.Optimizer.Common
+import Language.PureScript.CodeGen.JS.Common
import Language.PureScript.Names
-
+import Language.PureScript.CodeGen.JS.Optimizer.Common
import qualified Language.PureScript.Constants as C
shouldInline :: JS -> Bool
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
index 3a120a3..304d1fc 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Optimizer.MagicDo
+-- Module : Language.PureScript.CodeGen.JS.Optimizer.MagicDo
-- Copyright : (c) Phil Freeman 2013-14
-- License : MIT
--
@@ -14,18 +14,17 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.Optimizer.MagicDo (
+module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (
magicDo
) where
import Data.List (nub)
import Data.Maybe (fromJust, isJust)
-import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.CodeGen.Common (identToJs)
+import Language.PureScript.CodeGen.JS.Common
import Language.PureScript.Names
-
+import Language.PureScript.Options
import qualified Language.PureScript.Constants as C
magicDo :: Options mode -> JS -> JS
@@ -60,13 +59,11 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
-- Desugar pure
convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val
-- Desugar >>
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
- let JSReturn ret = last js in
- JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] )
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =
+ JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js )
-- Desugar >>=
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
- let JSReturn ret = last js in
- JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : init js ++ [JSReturn (JSApp ret [])] )
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind =
+ JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js)
-- Desugar untilE
convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =
JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []
@@ -107,8 +104,14 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
undo other = other
- isJSReturn (JSReturn _) = True
- isJSReturn _ = False
+ applyReturns :: JS -> JS
+ applyReturns (JSReturn ret) = JSReturn (JSApp ret [])
+ applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)
+ applyReturns (JSWhile cond js) = JSWhile cond (applyReturns js)
+ applyReturns (JSFor v lo hi js) = JSFor v lo hi (applyReturns js)
+ applyReturns (JSForIn v xs js) = JSForIn v xs (applyReturns js)
+ applyReturns (JSIfElse cond t f) = JSIfElse cond (applyReturns t) (applyReturns `fmap` f)
+ applyReturns other = other
-- |
-- Inline functions in the ST module
diff --git a/src/Language/PureScript/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
index 4541e73..4fc86fe 100644
--- a/src/Language/PureScript/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Optimizer.TCO
+-- Module : Language.PureScript.CodeGen.JS.Optimizer.TCO
-- Copyright : (c) Phil Freeman 2013-14
-- License : MIT
--
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.Optimizer.TCO (tco) where
+module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST
diff --git a/src/Language/PureScript/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
index 33a233d..3d748fc 100644
--- a/src/Language/PureScript/Optimizer/Unused.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Optimizer.Unused
+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Unused
-- Copyright : (c) Phil Freeman 2013-14
-- License : MIT
--
@@ -13,14 +13,14 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.Optimizer.Unused
+module Language.PureScript.CodeGen.JS.Optimizer.Unused
( removeCodeAfterReturnStatements
, removeUnusedArg
, removeUndefinedApp
) where
import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.Optimizer.Common
+import Language.PureScript.CodeGen.JS.Optimizer.Common
import qualified Language.PureScript.Constants as C
diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs
new file mode 100644
index 0000000..a1871da
--- /dev/null
+++ b/src/Language/PureScript/Comments.hs
@@ -0,0 +1,25 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Parser.Comments
+-- Copyright : (c) Phil Freeman 2015
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Defines the types of source code comments
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Language.PureScript.Comments where
+
+import qualified Data.Data as D
+
+data Comment
+ = LineComment String
+ | BlockComment String
+ deriving (Show, Eq, Ord, D.Data, D.Typeable) \ No newline at end of file
diff --git a/src/Language/PureScript/CoreFn.hs b/src/Language/PureScript/CoreFn.hs
new file mode 100644
index 0000000..a06840e
--- /dev/null
+++ b/src/Language/PureScript/CoreFn.hs
@@ -0,0 +1,26 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CoreFn
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- | The core functional representation
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.CoreFn (
+ module C
+) where
+
+import Language.PureScript.CoreFn.Ann as C
+import Language.PureScript.CoreFn.Binders as C
+import Language.PureScript.CoreFn.Desugar as C
+import Language.PureScript.CoreFn.Expr as C
+import Language.PureScript.CoreFn.Literals as C
+import Language.PureScript.CoreFn.Meta as C
+import Language.PureScript.CoreFn.Module as C
+import Language.PureScript.CoreFn.Traversals as C
diff --git a/src/Language/PureScript/CoreFn/Ann.hs b/src/Language/PureScript/CoreFn/Ann.hs
new file mode 100644
index 0000000..9bb65fb
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Ann.hs
@@ -0,0 +1,37 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CoreFn.Ann
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- | Type alias for basic annotations
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.CoreFn.Ann where
+
+import Language.PureScript.AST.SourcePos
+import Language.PureScript.CoreFn.Meta
+import Language.PureScript.Types
+import Language.PureScript.Comments
+
+-- |
+-- Type alias for basic annotations
+--
+type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta)
+
+-- |
+-- Initial annotation with no metadata
+--
+nullAnn :: Ann
+nullAnn = (Nothing, [], Nothing, Nothing)
+
+-- |
+-- Remove the comments from an annotation
+--
+removeComments :: Ann -> Ann
+removeComments (ss, _, ty, meta) = (ss, [], ty, meta) \ No newline at end of file
diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs
new file mode 100644
index 0000000..c88dceb
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Binders.hs
@@ -0,0 +1,47 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CoreFn.Binders
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- | The core functional representation for binders
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Language.PureScript.CoreFn.Binders where
+
+import qualified Data.Data as D
+
+import Language.PureScript.CoreFn.Literals
+import Language.PureScript.Names
+
+-- |
+-- Data type for binders
+--
+data Binder a
+ -- |
+ -- Wildcard binder
+ --
+ = NullBinder a
+ -- |
+ -- A binder which matches a literal value
+ --
+ | LiteralBinder a (Literal (Binder a))
+ -- |
+ -- A binder which binds an identifier
+ --
+ | VarBinder a Ident
+ -- |
+ -- A binder which matches a data constructor (type name, constructor name, binders)
+ --
+ | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]
+ -- |
+ -- A binder which binds its input to an identifier
+ --
+ | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable)
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
new file mode 100644
index 0000000..0748d18
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -0,0 +1,242 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CoreFn.Desugar
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- | The AST -> CoreFn desugaring step
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
+
+import Data.Function (on)
+import Data.List (sort, sortBy, nub)
+import Data.Maybe (mapMaybe)
+import qualified Data.Map as M
+
+import Control.Arrow (second, (***))
+
+import Language.PureScript.AST.SourcePos
+import Language.PureScript.AST.Traversals
+import Language.PureScript.CoreFn.Ann
+import Language.PureScript.CoreFn.Binders
+import Language.PureScript.CoreFn.Expr
+import Language.PureScript.CoreFn.Literals
+import Language.PureScript.CoreFn.Meta
+import Language.PureScript.CoreFn.Module
+import Language.PureScript.Environment
+import Language.PureScript.Names
+import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames)
+import Language.PureScript.Types
+import Language.PureScript.Comments
+import qualified Language.PureScript.AST as A
+
+-- |
+-- Desugars a module from AST to CoreFn representation.
+--
+moduleToCoreFn :: Environment -> A.Module -> Module Ann
+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
+ in Module mn imports exps' externs decls'
+moduleToCoreFn _ (A.Module{}) =
+ error "Module exports were not elaborated before moduleToCoreFn"
+
+findQualModules :: [A.Declaration] -> [ModuleName]
+findQualModules decls =
+ let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
+ in f `concatMap` decls
+ where
+ fqValues :: A.Expr -> [ModuleName]
+ fqValues (A.Var (Qualified (Just mn) _)) = [mn]
+ fqValues _ = []
+
+-- |
+-- Desugars import declarations from AST to CoreFn representation.
+--
+importToCoreFn :: A.Declaration -> Maybe ModuleName
+importToCoreFn (A.ImportDeclaration name _ _) = Just name
+importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d
+importToCoreFn _ = Nothing
+
+-- |
+-- Desugars foreign declarations from AST to CoreFn representation.
+--
+externToCoreFn :: A.Declaration -> Maybe ForeignDecl
+externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)
+externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)
+externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d
+externToCoreFn _ = Nothing
+
+-- |
+-- Desugars export declarations references from AST to CoreFn representation.
+-- CoreFn modules only export values, so all data constructors, class
+-- constructor, instances and values are flattened into one list.
+--
+exportToCoreFn :: A.DeclarationRef -> [Ident]
+exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors
+exportToCoreFn (A.ValueRef name) = [name]
+exportToCoreFn (A.TypeClassRef name) = [properToIdent name]
+exportToCoreFn (A.TypeInstanceRef name) = [name]
+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.
+--
+mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann
+mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])
+mkTypeClassConstructor ss com supers members =
+ let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers
+ props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]
+ dict = Literal nullAnn (ObjectLiteral props)
+ in Abs (ss, com, Nothing, Just IsTypeClassConstructor)
+ (Ident a)
+ (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
new file mode 100644
index 0000000..02fa24d
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -0,0 +1,125 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CoreFn.Expr
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- | The core functional representation
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Language.PureScript.CoreFn.Expr where
+
+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
+
+-- |
+-- Data type for expressions and terms
+--
+data Expr a
+ -- |
+ -- A literal value
+ --
+ = Literal a (Literal (Expr a))
+ -- |
+ -- A data constructor (type name, constructor name, arity)
+ --
+ | Constructor a ProperName ProperName Arity
+ -- |
+ -- A record property accessor
+ --
+ | Accessor a String (Expr a)
+ -- |
+ -- Partial record update
+ --
+ | ObjectUpdate a (Expr a) [(String, Expr a)]
+ -- |
+ -- Function introduction
+ --
+ | Abs a Ident (Expr a)
+ -- |
+ -- Function application
+ --
+ | App a (Expr a) (Expr a)
+ -- |
+ -- Variable
+ --
+ | Var a (Qualified Ident)
+ -- |
+ -- A case expression
+ --
+ | Case a [Expr a] [CaseAlternative a]
+ -- |
+ -- A let binding
+ --
+ | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable)
+
+-- |
+-- A let or module binding.
+--
+data Bind a
+ -- |
+ -- Non-recursive binding for a single value
+ --
+ = NonRec Ident (Expr a)
+ -- |
+ -- Mutually recursive binding group for several values
+ --
+ | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable)
+
+-- |
+-- A guard is just a boolean-valued expression that appears alongside a set of binders
+--
+type Guard a = Expr a
+
+-- |
+-- An alternative in a case statement
+--
+data CaseAlternative a = CaseAlternative
+ { -- |
+ -- A collection of binders with which to match the inputs
+ --
+ caseAlternativeBinders :: [Binder a]
+ -- |
+ -- The result expression or a collect of guarded expressions
+ --
+ , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
+ } deriving (Show, D.Data, D.Typeable)
+
+-- |
+-- Extract the annotation from a term
+--
+extractAnn :: Expr a -> a
+extractAnn (Literal a _) = a
+extractAnn (Constructor a _ _ _) = a
+extractAnn (Accessor a _ _) = a
+extractAnn (ObjectUpdate a _ _) = a
+extractAnn (Abs a _ _) = a
+extractAnn (App a _ _) = a
+extractAnn (Var a _) = a
+extractAnn (Case a _ _) = a
+extractAnn (Let a _ _) = a
+
+-- |
+-- Modify the annotation on a term
+--
+modifyAnn :: (a -> a) -> Expr a -> Expr a
+modifyAnn f (Literal a b) = Literal (f a) b
+modifyAnn f (Constructor a b c d) = Constructor (f a) b c d
+modifyAnn f (Accessor a b c) = Accessor (f a) b c
+modifyAnn f (ObjectUpdate a b c) = ObjectUpdate (f a) b c
+modifyAnn f (Abs a b c) = Abs (f a) b c
+modifyAnn f (App a b c) = App (f a) b c
+modifyAnn f (Var a b) = Var (f a) b
+modifyAnn f (Case a b c) = Case (f a) b c
+modifyAnn f (Let a b c) = Let (f a) b c
diff --git a/src/Language/PureScript/CoreFn/Literals.hs b/src/Language/PureScript/CoreFn/Literals.hs
new file mode 100644
index 0000000..8e56d97
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Literals.hs
@@ -0,0 +1,45 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CoreFn.Literals
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- | The core functional representation for literal values.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Language.PureScript.CoreFn.Literals where
+
+import qualified Data.Data as D
+
+-- |
+-- Data type for literal values. Parameterised so it can be used for Exprs and
+-- Binders.
+--
+data Literal a
+ -- |
+ -- A numeric literal
+ --
+ = NumericLiteral (Either Integer Double)
+ -- |
+ -- A string literal
+ --
+ | StringLiteral String
+ -- |
+ -- A boolean literal
+ --
+ | BooleanLiteral Bool
+ -- |
+ -- An array literal
+ --
+ | ArrayLiteral [a]
+ -- |
+ -- An object literal
+ --
+ | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable)
diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs
new file mode 100644
index 0000000..7c2199c
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Meta.hs
@@ -0,0 +1,54 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CoreFn.Meta
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- | Metadata annotations for core functional representation
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Language.PureScript.CoreFn.Meta where
+
+import qualified Data.Data as D
+
+-- |
+-- Metadata annotations
+--
+data Meta
+ -- |
+ -- The contained value is a data constructor
+ --
+ = IsConstructor ConstructorType Arity
+ -- |
+ -- The contained value is a newtype
+ --
+ | IsNewtype
+ -- |
+ -- The contained value is a typeclass dictionary constructor
+ --
+ | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)
+
+-- |
+-- Type alias for constructor arity
+--
+type Arity = Int
+
+-- |
+-- Data constructor metadata
+--
+data ConstructorType
+ -- |
+ -- The constructor is for a type with a single construcor
+ --
+ = ProductType
+ -- |
+ -- The constructor is for a type with multiple construcors
+ --
+ | SumType deriving (Show, D.Data, D.Typeable)
diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs
new file mode 100644
index 0000000..9f97ccb
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Module.hs
@@ -0,0 +1,30 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CoreFn.Module
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- | The CoreFn module representation
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.CoreFn.Module where
+
+import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.CoreFn.Expr
+import Language.PureScript.Names
+import Language.PureScript.Types
+
+data Module a = Module
+ { moduleName :: ModuleName
+ , moduleImports :: [ModuleName]
+ , moduleExports :: [Ident]
+ , moduleForeign :: [ForeignDecl]
+ , moduleDecls :: [Bind a]
+ } deriving (Show)
+
+type ForeignDecl = (Ident, Maybe JS, Type)
diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs
new file mode 100644
index 0000000..a579168
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Traversals.hs
@@ -0,0 +1,85 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CoreFn.Traversals
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- | CoreFn traversal helpers
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.CoreFn.Traversals where
+
+import Control.Arrow (second, (***), (+++))
+
+import Language.PureScript.CoreFn.Binders
+import Language.PureScript.CoreFn.Expr
+import Language.PureScript.CoreFn.Literals
+
+everywhereOnValues :: (Bind a -> Bind a) ->
+ (Expr a -> Expr a) ->
+ (Binder a -> Binder a) ->
+ (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)
+everywhereOnValues f g h = (f', g', h')
+ where
+ f' (NonRec name e) = f (NonRec name (g' e))
+ f' (Rec es) = f (Rec (map (second g') es))
+
+ g' (Literal ann e) = g (Literal ann (handleLiteral g' e))
+ g' (Accessor ann prop e) = g (Accessor ann prop (g' e))
+ g' (ObjectUpdate ann obj vs) = g (ObjectUpdate ann (g' obj) (map (fmap g') vs))
+ g' (Abs ann name e) = g (Abs ann name (g' e))
+ g' (App ann v1 v2) = g (App ann (g' v1) (g' v2))
+ g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts))
+ g' (Let ann ds e) = g (Let ann (map f' ds) (g' e))
+ g' e = g e
+
+ h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))
+ h' (NamedBinder a name b) = h (NamedBinder a name (h' b))
+ h' b = h b
+
+ handleCaseAlternative ca =
+ ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
+ , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
+ }
+
+ handleLiteral :: (a -> a) -> Literal a -> Literal a
+ handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls)
+ handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls)
+ handleLiteral _ other = other
+
+everythingOnValues :: (r -> r -> r) ->
+ (Bind a -> r) ->
+ (Expr a -> r) ->
+ (Binder a -> r) ->
+ (CaseAlternative a -> r) ->
+ (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)
+everythingOnValues (<>) f g h i = (f', g', h', i')
+ where
+ f' b@(NonRec _ e) = f b <> g' e
+ f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)
+
+ g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))
+ g' v@(Accessor _ _ e1) = g v <> g' e1
+ g' v@(ObjectUpdate _ obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
+ g' v@(Abs _ _ e1) = g v <> g' e1
+ g' v@(App _ e1 e2) = g v <> g' e1 <> g' e2
+ g' v@(Case _ vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
+ g' v@(Let _ ds e1) = foldl (<>) (g v) (map f' ds) <> g' e1
+ g' v = g v
+
+ h' b@(LiteralBinder _ l) = foldl (<>) (h b) (map h' (extractLiteral l))
+ h' b@(ConstructorBinder _ _ _ bs) = foldl (<>) (h b) (map h' bs)
+ h' b@(NamedBinder _ _ b1) = h b <> h' b1
+ h' b = h b
+
+ i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
+ i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
+
+ extractLiteral (ArrayLiteral xs) = xs
+ extractLiteral (ObjectLiteral xs) = map snd xs
+ extractLiteral _ = []
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 9f96f15..3213373 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -8,7 +8,7 @@
-- Stability : experimental
-- Portability :
--
--- |
+-- | Dead code elimination.
--
-----------------------------------------------------------------------------
@@ -16,98 +16,87 @@ module Language.PureScript.DeadCodeElimination (
eliminateDeadCode
) where
-import Data.List
import Data.Graph
+import Data.List
import Data.Maybe (mapMaybe)
+import Language.PureScript.CoreFn
import Language.PureScript.Names
-import Language.PureScript.AST
-- |
-- Eliminate all declarations which are not a transitive dependency of the entry point module
--
-eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]
+eliminateDeadCode :: [ModuleName] -> [Module a] -> [Module a]
eliminateDeadCode entryPoints ms = map go ms
where
- go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')
+ go (Module mn imps exps foreigns ds) = Module mn imps exps' foreigns' ds'
where
- ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds
- exps' = mapMaybe (filterExport ds') exps
- go _ = error "Exports should have been elaborated in name desugaring"
+ ds' = filter (isUsed mn graph vertexFor entryPointVertices) ds
+ foreigns' = filter (isUsed' mn graph vertexFor entryPointVertices . foreignIdent) foreigns
+ names = concatMap bindIdents ds' ++ map foreignIdent foreigns'
+ exps' = filter (`elem` names) exps
declarations = concatMap declarationsByModule ms
(graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
- filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef
- filterExport decls r@(TypeRef name _) | (any $ typeOrClassExists name) decls = Just r
- filterExport decls r@(TypeClassRef name) | (any $ typeOrClassExists name) decls = Just r
- filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r
- filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r
- filterExport _ _ = Nothing
-
- valueExists :: Ident -> Declaration -> Bool
- valueExists name (ValueDeclaration name' _ _ _) = name == name'
- valueExists name (ExternDeclaration _ name' _ _) = name == name'
- valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls
- valueExists name (PositionedDeclaration _ d) = valueExists name d
- valueExists _ _ = False
+-- |
+-- Extract declaration names for a binding group.
+--
+bindIdents :: Bind a -> [Ident]
+bindIdents (NonRec name _) = [name]
+bindIdents (Rec names) = map fst names
- typeOrClassExists :: ProperName -> Declaration -> Bool
- typeOrClassExists name (DataDeclaration _ name' _ _) = name == name'
- typeOrClassExists name (TypeClassDeclaration name' _ _ _) = name == name'
- typeOrClassExists name (DataBindingGroupDeclaration decls) = any (typeOrClassExists name) decls
- typeOrClassExists name (PositionedDeclaration _ d) = typeOrClassExists name d
- typeOrClassExists _ _ = False
+-- |
+-- Extract the ident for a foreign declaration.
+--
+foreignIdent :: ForeignDecl -> Ident
+foreignIdent (name, _, _) = name
-type Key = (ModuleName, Either Ident ProperName)
+-- |
+-- Key type to use in graph
+--
+type Key = (ModuleName, Ident)
-declarationsByModule :: Module -> [(Key, [Key])]
-declarationsByModule (Module moduleName ds _) = concatMap go ds
+-- |
+-- Find dependencies for each member in a module.
+--
+declarationsByModule :: Module a -> [(Key, [Key])]
+declarationsByModule (Module mn _ _ fs ds) =
+ let fs' = map ((\name -> ((mn, name), [])) . foreignIdent) fs
+ in fs' ++ concatMap go ds
where
- go :: Declaration -> [(Key, [Key])]
- go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
- go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
- go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
- go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
- go (DataBindingGroupDeclaration ds') = concatMap go ds'
- go (TypeClassDeclaration name _ _ _) = [((moduleName, Right name), [])]
- go (PositionedDeclaration _ d) = go d
- go _ = []
+ go :: Bind a -> [(Key, [Key])]
+ go d@(NonRec name _) = [((mn, name), dependencies d)]
+ go d@(Rec names') = map (\(name, _) -> ((mn, name), dependencies d)) names'
-dependencies :: ModuleName -> Declaration -> [Key]
-dependencies moduleName =
- let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])
+-- |
+-- Find all referenced values within a binding group.
+--
+dependencies :: Bind a -> [Key]
+dependencies =
+ let (f, _, _, _) = everythingOnValues (++) (const []) values binders (const [])
in nub . f
where
- values :: Expr -> [Key]
- values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
- values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
- values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
- values (TypeClassDictionaryConstructorApp (Qualified (Just mn) name) _) = [(mn, Right name)]
- values (TypeClassDictionaryConstructorApp (Qualified Nothing _) _) = error "Found unqualified class dictionary constructor"
+ values :: Expr a -> [Key]
+ values (Var _ (Qualified (Just mn) ident)) = [(mn, ident)]
values _ = []
+ binders :: Binder a -> [Key]
+ binders (ConstructorBinder _ _ (Qualified (Just mn) ident) _) = [(mn, Ident $ runProperName ident)]
+ binders _ = []
-isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
-isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =
- let Just v' = vertexFor (moduleName, Left name)
- in any (\v -> path graph v v') entryPointVertices
-isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =
- let Just v' = vertexFor (moduleName, Left $ Op name)
- in any (\v -> path graph v v') entryPointVertices
-isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ _ dctors) =
- any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)
- in any (\v -> path graph v v') entryPointVertices) dctors
-isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =
- let Just v' = vertexFor (moduleName, Left name)
- in any (\v -> path graph v v') entryPointVertices
-isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =
- any (\(name, _, _) -> let Just v' = vertexFor (moduleName, Left name)
- in any (\v -> path graph v v') entryPointVertices) ds
-isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
- any (isUsed moduleName graph vertexFor entryPointVertices) ds
-isUsed moduleName graph vertexFor entryPointVertices (TypeClassDeclaration name _ _ _) =
- let Just v' = vertexFor (moduleName, Right name)
+-- |
+-- Check whether a binding group is used.
+--
+isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Bind a -> Bool
+isUsed mn graph vertexFor entryPointVertices (NonRec name _) =
+ isUsed' mn graph vertexFor entryPointVertices name
+isUsed mn graph vertexFor entryPointVertices (Rec ds) =
+ any (isUsed' mn graph vertexFor entryPointVertices . fst) ds
+
+-- |
+-- Check whether a named declaration is used.
+--
+isUsed' :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Ident -> Bool
+isUsed' mn graph vertexFor entryPointVertices name =
+ let Just v' = vertexFor (mn, name)
in any (\v -> path graph v v') entryPointVertices
-isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =
- isUsed moduleName graph vertexFor entryPointVertices d
-isUsed _ _ _ _ _ = True
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index c65999f..347c50f 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -17,15 +17,15 @@
module Language.PureScript.Environment where
import Data.Data
+import Data.Maybe (fromMaybe)
+import qualified Data.Map as M
-import Language.PureScript.Names
-import Language.PureScript.Types
import Language.PureScript.Kinds
+import Language.PureScript.Names
import Language.PureScript.TypeClassDictionaries
+import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
-import qualified Data.Map as M
-
-- |
-- The @Environment@ defines all values and types which are currently in scope:
--
@@ -53,7 +53,7 @@ data Environment = Environment {
-- |
-- Type classes
--
- , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [(Qualified ProperName, [Type])])
+ , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
} deriving (Show)
-- |
@@ -219,3 +219,18 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star
, (primName "String" , (Star, ExternData))
, (primName "Number" , (Star, ExternData))
, (primName "Boolean" , (Star, ExternData)) ]
+
+-- |
+-- Finds information about data constructors from the current environment.
+--
+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)
+lookupConstructor env ctor =
+ fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env
+
+-- |
+-- Checks whether a data constructor is for a newtype.
+--
+isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
+isNewtypeConstructor e ctor = case lookupConstructor e ctor of
+ (Newtype, _, _) -> True
+ (Data, _, _) -> False
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 76ab371..b358b56 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -64,9 +64,6 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (
forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs
forTypes _ = []
-getModuleName :: Module -> ModuleName
-getModuleName (Module mn _ _) = mn
-
-- |
-- Convert a strongly connected component of the module graph to a module
--
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 1b64423..0ac1720 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
module Language.PureScript.Names where
@@ -71,7 +71,7 @@ instance Show ModuleName where
-- |
-- A qualified name, i.e. a name with an optional module name
--
-data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)
+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable, Functor)
instance (Show a) => Show (Qualified a) where
show (Qualified Nothing a) = show a
diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs
index 4176ed8..0e081ce 100644
--- a/src/Language/PureScript/Parser.hs
+++ b/src/Language/PureScript/Parser.hs
@@ -31,4 +31,5 @@ import Language.PureScript.Parser.Common as P
import Language.PureScript.Parser.Types as P
import Language.PureScript.Parser.State as P
import Language.PureScript.Parser.Kinds as P
+import Language.PureScript.Parser.Lexer as P
import Language.PureScript.Parser.Declarations as P \ No newline at end of file
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 0aac9de..ed9b750 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -17,299 +17,47 @@
module Language.PureScript.Parser.Common where
-import Data.Functor.Identity
import Control.Applicative
-import Control.Monad
-import Language.PureScript.Parser.State
-import qualified Text.Parsec as P
-import qualified Text.Parsec.Token as PT
+import Control.Monad (guard)
+import Language.PureScript.Comments
+import Language.PureScript.Parser.Lexer
+import Language.PureScript.Parser.State
import Language.PureScript.Names
--- |
--- A list of purescript reserved identifiers
---
-reservedPsNames :: [String]
-reservedPsNames = [ "data"
- , "newtype"
- , "type"
- , "foreign"
- , "import"
- , "infixl"
- , "infixr"
- , "infix"
- , "class"
- , "instance"
- , "module"
- , "case"
- , "of"
- , "if"
- , "then"
- , "else"
- , "do"
- , "let"
- , "true"
- , "false"
- , "in"
- , "where"
- ]
-
--- |
--- The characters allowed for use in operators
---
-opChars :: [Char]
-opChars = ":!#$%&*+./<=>?@\\^|-~"
-
--- |
--- A list of reserved identifiers for types
---
-reservedTypeNames :: [String]
-reservedTypeNames = [ "forall"
- , "where" ]
-
--- |
--- A list of reserved operators
---
-reservedOpNames :: [String]
-reservedOpNames = [ "=>", "->", "=", ".", "\\", "|" ]
-
--- |
--- Valid first characters for an identifier
---
-identStart :: P.Parsec String u Char
-identStart = P.lower <|> P.oneOf "_"
-
--- |
--- Valid identifier characters
---
-identLetter :: P.Parsec String u Char
-identLetter = P.alphaNum <|> P.oneOf "_'"
-
--- |
--- Valid first characters for an operator
---
-opStart :: P.Parsec String u Char
-opStart = P.oneOf opChars
-
--- |
--- Valid operators characters
---
-opLetter :: P.Parsec String u Char
-opLetter = P.oneOf opChars
-
--- |
--- The PureScript language definition
---
-langDef :: PT.GenLanguageDef String u Identity
-langDef = PT.LanguageDef
- { PT.reservedNames = reservedPsNames
- , PT.reservedOpNames = reservedOpNames
- , PT.commentStart = "{-"
- , PT.commentEnd = "-}"
- , PT.commentLine = "--"
- , PT.nestedComments = True
- , PT.identStart = identStart
- , PT.identLetter = identLetter
- , PT.opStart = opStart
- , PT.opLetter = opLetter
- , PT.caseSensitive = True
- }
-
--- |
--- A token parser based on the language definition
---
-tokenParser :: PT.GenTokenParser String u Identity
-tokenParser = PT.makeTokenParser langDef
-
--- |
--- Parse a token
---
-lexeme :: P.Parsec String u a -> P.Parsec String u a
-lexeme = PT.lexeme tokenParser
-
--- |
--- Parse an identifier
---
-identifier :: P.Parsec String u String
-identifier = PT.identifier tokenParser
-
--- |
--- Parse an identifier in a more permissive position
---
-identifierName :: P.Parsec String u String
-identifierName = lexeme $ (:) <$> identStart <*> many identLetter
-
--- |
--- Parse a reserved word
---
-reserved :: String -> P.Parsec String u ()
-reserved = PT.reserved tokenParser
-
--- |
--- Parse a reserved operator
---
-reservedOp :: String -> P.Parsec String u ()
-reservedOp = PT.reservedOp tokenParser
-
--- |
--- Parse an operator
---
-operator :: P.Parsec String u String
-operator = PT.operator tokenParser
-
--- |
--- Parse a string literal
---
-stringLiteral :: P.Parsec String u String
-stringLiteral = lexeme blockString <|> PT.stringLiteral tokenParser
- where delimeter = P.try (P.string "\"\"\"")
- blockString = delimeter >> P.manyTill P.anyChar delimeter
-
--- |
--- Parse whitespace
---
-whiteSpace :: P.Parsec String u ()
-whiteSpace = PT.whiteSpace tokenParser
-
--- |
--- Semicolon
---
-semi :: P.Parsec String u String
-semi = PT.semi tokenParser
-
--- |
--- Colon
---
-colon :: P.Parsec String u String
-colon = PT.colon tokenParser
-
--- |
--- Period
---
-dot :: P.Parsec String u String
-dot = PT.dot tokenParser
-
--- |
--- Comma
---
-comma :: P.Parsec String u String
-comma = PT.comma tokenParser
-
--- |
--- Backtick
---
-tick :: P.Parsec String u Char
-tick = lexeme $ P.char '`'
-
--- |
--- Pipe character
---
-pipe :: P.Parsec String u Char
-pipe = lexeme $ P.char '|'
-
--- |
--- Natural number
---
-natural :: P.Parsec String u Integer
-natural = PT.natural tokenParser
+import qualified Text.Parsec as P
--- |
--- Parse a proper name
---
-properName :: P.Parsec String u ProperName
-properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum P.<?> "name")
+properName :: TokenParser ProperName
+properName = ProperName <$> uname
-- |
-- Parse a module name
--
-moduleName :: P.Parsec String ParseState ModuleName
-moduleName = ModuleName <$> P.try (sepBy properName dot)
+moduleName :: TokenParser ModuleName
+moduleName = part []
+ where
+ part path = (do name <- ProperName <$> P.try qualifier
+ part (path `snoc` name))
+ <|> (ModuleName . snoc path . ProperName <$> mname)
+ snoc path name = path ++ [name]
-- |
-- Parse a qualified name, i.e. M.name or just name
--
-parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
+parseQualified :: TokenParser a -> TokenParser (Qualified a)
parseQualified parser = part []
where
- part path = (do name <- P.try (properName <* delimiter)
+ part path = (do name <- ProperName <$> P.try qualifier
part (updatePath path name))
<|> (Qualified (qual path) <$> P.try parser)
- delimiter = indented *> dot <* P.notFollowedBy dot
updatePath path name = path ++ [name]
qual path = if null path then Nothing else Just $ ModuleName path
-- |
--- Parse an integer or floating point value
---
-integerOrFloat :: P.Parsec String u (Either Integer Double)
-integerOrFloat = (Right <$> P.try (PT.float tokenParser) <|>
- Left <$> P.try (PT.natural tokenParser)) P.<?> "number"
-
--- |
-- Parse an identifier or parenthesized operator
--
-parseIdent :: P.Parsec String ParseState Ident
-parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)
-
--- |
--- Parse a token inside square brackets
---
-squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a
-squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>)
-
--- |
--- Parse a token inside parentheses
---
-parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a
-parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)
-
--- |
--- Parse a token inside braces
---
-braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a
-braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)
-
--- |
--- Parse a token inside angle brackets
---
-angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a
-angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>)
-
--- |
--- Parse zero or more values separated by a separator token
---
-sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
-sepBy p s = P.sepBy (indented *> p) (indented *> s)
-
--- |
--- Parse one or more values separated by a separator token
---
-sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
-sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s)
-
--- |
--- Parse zero or more values separated by semicolons
---
-semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
-semiSep = flip sepBy semi
-
--- |
--- Parse one or more values separated by semicolons
---
-semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
-semiSep1 = flip sepBy1 semi
-
--- |
--- Parse zero or more values separated by commas
---
-commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
-commaSep = flip sepBy comma
-
--- |
--- Parse one or more values separated by commas
---
-commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
-commaSep1 = flip sepBy1 comma
+parseIdent :: TokenParser Ident
+parseIdent = (Ident <$> identifier) <|> (Op <$> parens symbol)
-- |
-- Run the first parser, then match the second if possible, applying the specified function on a successful match
@@ -343,13 +91,13 @@ buildPostfixParser fs first = do
-- |
-- Parse an identifier in backticks or an operator
--
-parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
-parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> operator))
+parseIdentInfix :: TokenParser (Qualified Ident)
+parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> symbol))
-- |
-- Mark the current indentation level
--
-mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a
+mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a
mark p = do
current <- indentationLevel <$> P.getState
pos <- P.sourceColumn <$> P.getPosition
@@ -361,7 +109,7 @@ mark p = do
-- |
-- Check that the current identation level matches a predicate
--
-checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()
+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState ()
checkIndentation rel = do
col <- P.sourceColumn <$> P.getPosition
current <- indentationLevel <$> P.getState
@@ -370,18 +118,23 @@ checkIndentation rel = do
-- |
-- Check that the current indentation level is past the current mark
--
-indented :: P.Parsec String ParseState ()
+indented :: P.Parsec s ParseState ()
indented = checkIndentation (>) P.<?> "indentation"
-- |
-- Check that the current indentation level is at the same indentation as the current mark
--
-same :: P.Parsec String ParseState ()
+same :: P.Parsec s ParseState ()
same = checkIndentation (==) P.<?> "no indentation"
-- |
--- Run a parser which supports indentation
+-- Read the comments from the the next token, without consuming it
--
-runIndentParser :: FilePath -> P.Parsec String ParseState a -> String -> Either P.ParseError a
-runIndentParser filePath p = P.runParser p (ParseState 0) filePath
+readComments :: P.Parsec [PositionedToken] u [Comment]
+readComments = P.lookAhead $ ptComments <$> P.anyToken
+-- |
+-- Run a parser
+--
+runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a
+runTokenParser filePath p = P.runParser p (ParseState 0) filePath
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 1ddf92f..3226be1 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -26,6 +26,8 @@ module Language.PureScript.Parser.Declarations (
parseBinderNoParens,
) where
+import Prelude hiding (lex)
+
import Data.Maybe (isJust, fromMaybe)
import Data.Traversable (forM)
@@ -33,11 +35,12 @@ import Control.Applicative
import Control.Arrow ((+++))
import Language.PureScript.Kinds
-import Language.PureScript.Parser.State
-import Language.PureScript.Parser.Common
import Language.PureScript.AST
+import Language.PureScript.Comments
+import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
+import Language.PureScript.Parser.Lexer
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
@@ -48,53 +51,54 @@ import qualified Text.Parsec.Expr as P
-- |
-- Read source position information
--
-withSourceSpan :: (SourceSpan -> a -> a) -> P.Parsec s u a -> P.Parsec s u a
+withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a
withSourceSpan f p = do
start <- P.getPosition
+ comments <- C.readComments
x <- p
end <- P.getPosition
let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
- return $ f sp x
+ return $ f sp comments x
where
toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
-kindedIdent :: P.Parsec String ParseState (String, Maybe Kind)
+kindedIdent :: TokenParser (String, Maybe Kind)
kindedIdent = (, Nothing) <$> identifier
- <|> parens ((,) <$> identifier <*> (Just <$> (indented *> lexeme (P.string "::") *> indented *> parseKind)))
+ <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))
-parseDataDeclaration :: P.Parsec String ParseState Declaration
+parseDataDeclaration :: TokenParser Declaration
parseDataDeclaration = do
dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
name <- indented *> properName
tyArgs <- many (indented *> kindedIdent)
ctors <- P.option [] $ do
- _ <- lexeme $ indented *> P.char '='
- sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
+ indented *> equals
+ P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
return $ DataDeclaration dtype name tyArgs ctors
-parseTypeDeclaration :: P.Parsec String ParseState Declaration
+parseTypeDeclaration :: TokenParser Declaration
parseTypeDeclaration =
- TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))
+ TypeDeclaration <$> P.try (parseIdent <* indented <* doubleColon)
<*> parsePolyType
-parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
+parseTypeSynonymDeclaration :: TokenParser Declaration
parseTypeSynonymDeclaration =
TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
<*> many (indented *> kindedIdent)
- <*> (lexeme (indented *> P.char '=') *> noWildcards parsePolyType)
+ <*> (indented *> equals *> noWildcards parsePolyType)
-parseValueDeclaration :: P.Parsec String ParseState Declaration
+parseValueDeclaration :: TokenParser Declaration
parseValueDeclaration = do
name <- parseIdent
binders <- P.many parseBinderNoParens
value <- Left <$> (C.indented *>
P.many1 ((,) <$> parseGuard
- <*> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)
+ <*> (indented *> equals *> parseValueWithWhereClause)
))
- <|> Right <$> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)
+ <|> Right <$> (indented *> equals *> parseValueWithWhereClause)
return $ ValueDeclaration name Value binders value
where
- parseValueWithWhereClause :: P.Parsec String ParseState Expr
+ parseValueWithWhereClause :: TokenParser Expr
parseValueWithWhereClause = do
value <- parseValue
whereClause <- P.optionMaybe $ do
@@ -104,42 +108,42 @@ parseValueDeclaration = do
C.mark $ P.many1 (C.same *> parseLocalDeclaration)
return $ maybe value (`Let` value) whereClause
-parseExternDeclaration :: P.Parsec String ParseState Declaration
+parseExternDeclaration :: TokenParser Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
(ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
- <*> (lexeme (indented *> P.string "::") *> parseKind)
+ <*> (indented *> doubleColon *> parseKind)
<|> (do reserved "instance"
- name <- parseIdent <* lexeme (indented *> P.string "::")
+ name <- parseIdent <* indented <* doubleColon
deps <- P.option [] $ do
deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
indented
- reservedOp "=>"
+ rfatArrow
return deps
className <- indented *> parseQualified properName
tys <- P.many (indented *> noWildcards parseTypeAtom)
return $ ExternInstanceDeclaration name deps className tys)
<|> (do ident <- parseIdent
js <- P.optionMaybe (JSRaw <$> stringLiteral)
- ty <- lexeme (indented *> P.string "::") *> noWildcards parsePolyType
+ ty <- indented *> doubleColon *> noWildcards parsePolyType
return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))
-parseAssociativity :: P.Parsec String ParseState Associativity
+parseAssociativity :: TokenParser Associativity
parseAssociativity =
(P.try (reserved "infixl") >> return Infixl) <|>
(P.try (reserved "infixr") >> return Infixr) <|>
(P.try (reserved "infix") >> return Infix)
-parseFixity :: P.Parsec String ParseState Fixity
+parseFixity :: TokenParser Fixity
parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
-parseFixityDeclaration :: P.Parsec String ParseState Declaration
+parseFixityDeclaration :: TokenParser Declaration
parseFixityDeclaration = do
fixity <- parseFixity
indented
- name <- operator
+ name <- symbol
return $ FixityDeclaration fixity name
-parseImportDeclaration :: P.Parsec String ParseState Declaration
+parseImportDeclaration :: TokenParser Declaration
parseImportDeclaration = do
reserved "import"
indented
@@ -169,20 +173,20 @@ parseImportDeclaration = do
return $ fromMaybe Unqualified (expectedType <$> idents)
-parseDeclarationRef :: P.Parsec String ParseState DeclarationRef
+parseDeclarationRef :: TokenParser DeclarationRef
parseDeclarationRef = withSourceSpan PositionedDeclarationRef $
ValueRef <$> parseIdent
<|> do name <- properName
- dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)
+ dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
return $ maybe (TypeClassRef name) (TypeRef name) dctors
-parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
+parseTypeClassDeclaration :: TokenParser Declaration
parseTypeClassDeclaration = do
reserved "class"
implies <- P.option [] $ do
indented
implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
- reservedOp "<="
+ lfatArrow
return implies
className <- indented *> properName
idents <- P.many (indented *> kindedIdent)
@@ -191,14 +195,14 @@ parseTypeClassDeclaration = do
mark (P.many (same *> positioned parseTypeDeclaration))
return $ TypeClassDeclaration className idents implies members
-parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
+parseTypeInstanceDeclaration :: TokenParser Declaration
parseTypeInstanceDeclaration = do
reserved "instance"
- name <- parseIdent <* lexeme (indented *> P.string "::")
+ name <- parseIdent <* indented <* doubleColon
deps <- P.optionMaybe $ do
deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
indented
- reservedOp "=>"
+ rfatArrow
return deps
className <- indented *> parseQualified properName
ty <- P.many (indented *> (noWildcards parseTypeAtom))
@@ -207,13 +211,13 @@ parseTypeInstanceDeclaration = do
mark (P.many (same *> positioned parseValueDeclaration))
return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
-positioned :: P.Parsec String ParseState Declaration -> P.Parsec String ParseState Declaration
+positioned :: TokenParser Declaration -> TokenParser Declaration
positioned d = withSourceSpan PositionedDeclaration d
-- |
-- Parse a single declaration
--
-parseDeclaration :: P.Parsec String ParseState Declaration
+parseDeclaration :: TokenParser Declaration
parseDeclaration = positioned (P.choice
[ parseDataDeclaration
, parseTypeDeclaration
@@ -226,7 +230,7 @@ parseDeclaration = positioned (P.choice
, parseTypeInstanceDeclaration
]) P.<?> "declaration"
-parseLocalDeclaration :: P.Parsec String ParseState Declaration
+parseLocalDeclaration :: TokenParser Declaration
parseLocalDeclaration = positioned (P.choice
[ parseTypeDeclaration
, parseValueDeclaration
@@ -235,13 +239,13 @@ parseLocalDeclaration = positioned (P.choice
-- |
-- Parse a module header and a collection of declarations
--
-parseModule :: P.Parsec String ParseState Module
+parseModule :: TokenParser Module
parseModule = do
reserved "module"
indented
name <- moduleName
exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
- _ <- lexeme $ P.string "where"
+ reserved "where"
decls <- mark (P.many (same *> parseDeclaration))
return $ Module name decls exports
@@ -250,9 +254,11 @@ parseModule = do
--
parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]
parseModulesFromFiles toFilePath input =
- fmap collect . forM input $ \(filename, content) -> do
- ms <- runIndentParser (toFilePath filename) parseModules content
- return (filename, ms)
+ fmap collect . forM input $ \(k, content) -> do
+ let filename = toFilePath k
+ ts <- lex filename content
+ ms <- runTokenParser filename parseModules ts
+ return (k, ms)
where
collect :: [(k, [v])] -> [(k, v)]
collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
@@ -260,77 +266,77 @@ parseModulesFromFiles toFilePath input =
-- |
-- Parse a collection of modules
--
-parseModules :: P.Parsec String ParseState [Module]
-parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
+parseModules :: TokenParser [Module]
+parseModules = mark (P.many (same *> parseModule)) <* P.eof
-booleanLiteral :: P.Parsec String ParseState Bool
-booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
+booleanLiteral :: TokenParser Bool
+booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)
-parseNumericLiteral :: P.Parsec String ParseState Expr
-parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
+parseNumericLiteral :: TokenParser Expr
+parseNumericLiteral = NumericLiteral <$> number
-parseStringLiteral :: P.Parsec String ParseState Expr
-parseStringLiteral = StringLiteral <$> C.stringLiteral
+parseStringLiteral :: TokenParser Expr
+parseStringLiteral = StringLiteral <$> stringLiteral
-parseBooleanLiteral :: P.Parsec String ParseState Expr
+parseBooleanLiteral :: TokenParser Expr
parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
-parseArrayLiteral :: P.Parsec String ParseState Expr
-parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
+parseArrayLiteral :: TokenParser Expr
+parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
-parseObjectLiteral :: P.Parsec String ParseState Expr
-parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
+parseObjectLiteral :: TokenParser Expr
+parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)
-parseIdentifierAndValue :: P.Parsec String ParseState (String, Expr)
-parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifierName <|> C.stringLiteral) <* C.indented <* C.colon)
+parseIdentifierAndValue :: TokenParser (String, Expr)
+parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)
<*> (C.indented *> parseValue)
-parseAbs :: P.Parsec String ParseState Expr
+parseAbs :: TokenParser Expr
parseAbs = do
- C.reservedOp "\\"
+ symbol' "\\"
args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
- C.indented *> C.reservedOp "->"
+ C.indented *> rarrow
value <- parseValue
return $ toFunction args value
where
toFunction :: [Expr -> Expr] -> Expr -> Expr
toFunction args value = foldr ($) value args
-parseVar :: P.Parsec String ParseState Expr
+parseVar :: TokenParser Expr
parseVar = Var <$> C.parseQualified C.parseIdent
-parseConstructor :: P.Parsec String ParseState Expr
+parseConstructor :: TokenParser Expr
parseConstructor = Constructor <$> C.parseQualified C.properName
-parseCase :: P.Parsec String ParseState Expr
-parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
+parseCase :: TokenParser Expr
+parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)
<*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
-parseCaseAlternative :: P.Parsec String ParseState CaseAlternative
+parseCaseAlternative :: TokenParser CaseAlternative
parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
<*> (Left <$> (C.indented *>
P.many1 ((,) <$> parseGuard
- <*> (lexeme (indented *> C.reservedOp "->") *> parseValue)
+ <*> (indented *> rarrow *> parseValue)
))
- <|> Right <$> (lexeme (indented *> C.reservedOp "->") *> parseValue))
+ <|> Right <$> (indented *> rarrow *> parseValue))
P.<?> "case alternative"
-parseIfThenElse :: P.Parsec String ParseState Expr
-parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
- <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
- <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
+parseIfThenElse :: TokenParser Expr
+parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)
+ <*> (C.indented *> reserved "then" *> C.indented *> parseValue)
+ <*> (C.indented *> reserved "else" *> C.indented *> parseValue)
-parseLet :: P.Parsec String ParseState Expr
+parseLet :: TokenParser Expr
parseLet = do
- C.reserved "let"
+ reserved "let"
C.indented
ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
C.indented
- C.reserved "in"
+ reserved "in"
result <- parseValue
return $ Let ds result
-parseValueAtom :: P.Parsec String ParseState Expr
+parseValueAtom :: TokenParser Expr
parseValueAtom = P.choice
[ P.try parseNumericLiteral
, P.try parseStringLiteral
@@ -344,32 +350,32 @@ parseValueAtom = P.choice
, parseIfThenElse
, parseDo
, parseLet
- , Parens <$> C.parens parseValue ]
+ , Parens <$> parens parseValue ]
-parsePropertyUpdate :: P.Parsec String ParseState (String, Expr)
+parsePropertyUpdate :: TokenParser (String, Expr)
parsePropertyUpdate = do
- name <- C.lexeme (C.identifierName <|> C.stringLiteral)
- _ <- C.lexeme $ C.indented *> P.char '='
+ name <- lname <|> stringLiteral
+ _ <- C.indented *> equals
value <- C.indented *> parseValue
return (name, value)
-parseAccessor :: Expr -> P.Parsec String ParseState Expr
+parseAccessor :: Expr -> TokenParser Expr
parseAccessor (Constructor _) = P.unexpected "constructor"
-parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifierName <|> C.stringLiteral)) <*> pure obj
+parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj
-parseDo :: P.Parsec String ParseState Expr
+parseDo :: TokenParser Expr
parseDo = do
- C.reserved "do"
+ reserved "do"
C.indented
Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
-parseDoNotationLet :: P.Parsec String ParseState DoNotationElement
-parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
+parseDoNotationLet :: TokenParser DoNotationElement
+parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
-parseDoNotationBind :: P.Parsec String ParseState DoNotationElement
-parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)
+parseDoNotationBind :: TokenParser DoNotationElement
+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)
-parseDoNotationElement :: P.Parsec String ParseState DoNotationElement
+parseDoNotationElement :: TokenParser DoNotationElement
parseDoNotationElement = P.choice
[ P.try parseDoNotationBind
, parseDoNotationLet
@@ -378,7 +384,7 @@ parseDoNotationElement = P.choice
-- |
-- Parse a value
--
-parseValue :: P.Parsec String ParseState Expr
+parseValue :: TokenParser Expr
parseValue = withSourceSpan PositionedValue
(P.buildExpressionParser operators
. C.buildPostfixParser postfixTable2
@@ -386,68 +392,68 @@ parseValue = withSourceSpan PositionedValue
where
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
postfixTable1 = [ parseAccessor
- , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
+ , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
- , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v
+ , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v
]
- operators = [ [ P.Prefix (C.lexeme (P.try (C.indented *> P.char '-') >> return UnaryMinus))
+ operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)
]
- , [ P.Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
- return (BinaryNoParens ident))) P.AssocRight
+ , [ P.Infix (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
+ return (BinaryNoParens ident)) P.AssocRight
]
]
-parseStringBinder :: P.Parsec String ParseState Binder
-parseStringBinder = StringBinder <$> C.stringLiteral
+parseStringBinder :: TokenParser Binder
+parseStringBinder = StringBinder <$> stringLiteral
-parseBooleanBinder :: P.Parsec String ParseState Binder
+parseBooleanBinder :: TokenParser Binder
parseBooleanBinder = BooleanBinder <$> booleanLiteral
-parseNumberBinder :: P.Parsec String ParseState Binder
-parseNumberBinder = NumberBinder <$> (C.lexeme sign <*> C.integerOrFloat)
+parseNumberBinder :: TokenParser Binder
+parseNumberBinder = NumberBinder <$> (sign <*> number)
where
- sign :: P.Parsec String ParseState (Either Integer Double -> Either Integer Double)
- sign = (P.char '-' >> return (negate +++ negate))
- <|> (P.char '+' >> return id)
+ sign :: TokenParser (Either Integer Double -> Either Integer Double)
+ sign = (symbol' "-" >> return (negate +++ negate))
+ <|> (symbol' "+" >> return id)
<|> return id
-parseVarBinder :: P.Parsec String ParseState Binder
+parseVarBinder :: TokenParser Binder
parseVarBinder = VarBinder <$> C.parseIdent
-parseNullaryConstructorBinder :: P.Parsec String ParseState Binder
-parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []
+parseNullaryConstructorBinder :: TokenParser Binder
+parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
-parseConstructorBinder :: P.Parsec String ParseState Binder
-parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)
+parseConstructorBinder :: TokenParser Binder
+parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
-parseObjectBinder :: P.Parsec String ParseState Binder
-parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
+parseObjectBinder :: TokenParser Binder
+parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))
-parseArrayBinder :: P.Parsec String ParseState Binder
-parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)
+parseArrayBinder :: TokenParser Binder
+parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
-parseNamedBinder :: P.Parsec String ParseState Binder
-parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
+parseNamedBinder :: TokenParser Binder
+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)
<*> (C.indented *> parseBinder)
-parseNullBinder :: P.Parsec String ParseState Binder
-parseNullBinder = C.lexeme (P.char '_' *> P.notFollowedBy C.identLetter) *> return NullBinder
+parseNullBinder :: TokenParser Binder
+parseNullBinder = reserved "_" *> return NullBinder
-parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
+parseIdentifierAndBinder :: TokenParser (String, Binder)
parseIdentifierAndBinder = do
- name <- C.lexeme (C.identifierName <|> C.stringLiteral)
- _ <- C.lexeme $ C.indented *> P.char '='
+ name <- lname <|> stringLiteral
+ C.indented *> (equals <|> colon)
binder <- C.indented *> parseBinder
return (name, binder)
-- |
-- Parse a binder
--
-parseBinder :: P.Parsec String ParseState Binder
+parseBinder :: TokenParser Binder
parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom P.<?> "expression")
where
- operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]
- parseBinderAtom :: P.Parsec String ParseState Binder
+ operators = [ [ P.Infix (P.try $ C.indented *> colon *> return ConsBinder) P.AssocRight ] ]
+ parseBinderAtom :: TokenParser Binder
parseBinderAtom = P.choice (map P.try
[ parseNullBinder
, parseStringBinder
@@ -458,12 +464,12 @@ parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators
, parseConstructorBinder
, parseObjectBinder
, parseArrayBinder
- , C.parens parseBinder ]) P.<?> "binder"
+ , parens parseBinder ]) P.<?> "binder"
-- |
-- Parse a binder as it would appear in a top level declaration
--
-parseBinderNoParens :: P.Parsec String ParseState Binder
+parseBinderNoParens :: TokenParser Binder
parseBinderNoParens = P.choice (map P.try
[ parseNullBinder
, parseStringBinder
@@ -474,11 +480,11 @@ parseBinderNoParens = P.choice (map P.try
, parseNullaryConstructorBinder
, parseObjectBinder
, parseArrayBinder
- , C.parens parseBinder ]) P.<?> "binder"
+ , parens parseBinder ]) P.<?> "binder"
-- |
-- Parse a guard
--
-parseGuard :: P.Parsec String ParseState Guard
-parseGuard = C.pipe *> C.indented *> parseValue
+parseGuard :: TokenParser Guard
+parseGuard = pipe *> C.indented *> parseValue
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
index 9e06c65..230f78f 100644
--- a/src/Language/PureScript/Parser/Kinds.hs
+++ b/src/Language/PureScript/Parser/Kinds.hs
@@ -18,19 +18,19 @@ module Language.PureScript.Parser.Kinds (
) where
import Language.PureScript.Kinds
-import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
+import Language.PureScript.Parser.Lexer
import Control.Applicative
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
-parseStar :: P.Parsec String ParseState Kind
-parseStar = const Star <$> lexeme (P.char '*')
+parseStar :: TokenParser Kind
+parseStar = const Star <$> symbol' "*"
-parseBang :: P.Parsec String ParseState Kind
-parseBang = const Bang <$> lexeme (P.char '!')
+parseBang :: TokenParser Kind
+parseBang = const Bang <$> symbol' "!"
-parseTypeAtom :: P.Parsec String ParseState Kind
+parseTypeAtom :: TokenParser Kind
parseTypeAtom = indented *> P.choice (map P.try
[ parseStar
, parseBang
@@ -38,8 +38,8 @@ parseTypeAtom = indented *> P.choice (map P.try
-- |
-- Parse a kind
--
-parseKind :: P.Parsec String ParseState Kind
+parseKind :: TokenParser Kind
parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
where
- operators = [ [ P.Prefix (lexeme (P.char '#') >> return Row) ]
- , [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]
+ operators = [ [ P.Prefix (symbol' "#" >> return Row) ]
+ , [ P.Infix ((P.try rarrow) >> return FunKind) P.AssocRight ] ]
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
new file mode 100644
index 0000000..945ccef
--- /dev/null
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -0,0 +1,491 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Parser.Lexer
+-- Copyright : (c) Phil Freeman 2014
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- The first step in the parsing process - turns source code into a list of lexemes
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE TupleSections #-}
+
+module Language.PureScript.Parser.Lexer
+ ( PositionedToken(..)
+ , Token()
+ , TokenParser()
+ , lex
+ , anyToken
+ , token
+ , match
+ , lparen
+ , rparen
+ , parens
+ , lbrace
+ , rbrace
+ , braces
+ , lsquare
+ , rsquare
+ , squares
+ , indent
+ , indentAt
+ , larrow
+ , rarrow
+ , lfatArrow
+ , rfatArrow
+ , colon
+ , doubleColon
+ , equals
+ , pipe
+ , tick
+ , dot
+ , comma
+ , semi
+ , at
+ , semiSep
+ , semiSep1
+ , commaSep
+ , commaSep1
+ , lname
+ , qualifier
+ , uname
+ , uname'
+ , mname
+ , reserved
+ , symbol
+ , symbol'
+ , identifier
+ , stringLiteral
+ , number
+ , natural
+ , reservedPsNames
+ , reservedTypeNames
+ , opChars
+ )
+ where
+
+import Prelude hiding (lex)
+
+import Data.Char (isSpace)
+
+import Control.Monad (void, guard)
+import Data.Functor.Identity
+
+import Control.Applicative
+
+import Language.PureScript.Parser.State
+import Language.PureScript.Comments
+
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Token as PT
+
+data Token
+ = LParen
+ | RParen
+ | LBrace
+ | RBrace
+ | LSquare
+ | RSquare
+ | Indent Int
+ | LArrow
+ | RArrow
+ | LFatArrow
+ | RFatArrow
+ | Colon
+ | DoubleColon
+ | Equals
+ | Pipe
+ | Tick
+ | Dot
+ | Comma
+ | Semi
+ | At
+ | LName String
+ | UName String
+ | Qualifier String
+ | Symbol String
+ | StringLiteral String
+ | Number (Either Integer Double)
+ deriving (Show, Eq, Ord)
+
+prettyPrintToken :: Token -> String
+prettyPrintToken LParen = "("
+prettyPrintToken RParen = ")"
+prettyPrintToken LBrace = "{"
+prettyPrintToken RBrace = "}"
+prettyPrintToken LSquare = "["
+prettyPrintToken RSquare = "]"
+prettyPrintToken LArrow = "<-"
+prettyPrintToken RArrow = "->"
+prettyPrintToken LFatArrow = "<="
+prettyPrintToken RFatArrow = "=>"
+prettyPrintToken Colon = ":"
+prettyPrintToken DoubleColon = "::"
+prettyPrintToken Equals = "="
+prettyPrintToken Pipe = "|"
+prettyPrintToken Tick = "`"
+prettyPrintToken Dot = "."
+prettyPrintToken Comma = ","
+prettyPrintToken Semi = ";"
+prettyPrintToken At = "@"
+prettyPrintToken (Indent n) = "indentation at level " ++ show n
+prettyPrintToken (LName s) = show s
+prettyPrintToken (UName s) = show s
+prettyPrintToken (Qualifier _) = "qualifier"
+prettyPrintToken (Symbol s) = s
+prettyPrintToken (StringLiteral s) = show s
+prettyPrintToken (Number n) = either show show n
+
+data PositionedToken = PositionedToken
+ { ptSourcePos :: P.SourcePos
+ , ptToken :: Token
+ , ptComments :: [Comment]
+ } deriving (Eq)
+
+instance Show PositionedToken where
+ show = show . ptToken
+
+lex :: FilePath -> String -> Either P.ParseError [PositionedToken]
+lex filePath input = P.parse parseTokens filePath input
+
+parseTokens :: P.Parsec String u [PositionedToken]
+parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof
+
+whitespace :: P.Parsec String u ()
+whitespace = P.skipMany (P.satisfy isSpace)
+
+parseComment :: P.Parsec String u Comment
+parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace
+ where
+ blockComment :: P.Parsec String u String
+ blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))
+
+ lineComment :: P.Parsec String u String
+ lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))
+
+parsePositionedToken :: P.Parsec String u PositionedToken
+parsePositionedToken = P.try $ do
+ comments <- P.many parseComment
+ pos <- P.getPosition
+ tok <- parseToken
+ return $ PositionedToken pos tok comments
+
+parseToken :: P.Parsec String u Token
+parseToken = P.choice
+ [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow
+ , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow
+ , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow
+ , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow
+ , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon
+ , P.try $ P.char '(' *> pure LParen
+ , P.try $ P.char ')' *> pure RParen
+ , P.try $ P.char '{' *> pure LBrace
+ , P.try $ P.char '}' *> pure RBrace
+ , P.try $ P.char '[' *> pure LSquare
+ , P.try $ P.char ']' *> pure RSquare
+ , P.try $ P.char '`' *> pure Tick
+ , P.try $ P.char ',' *> pure Comma
+ , P.try $ P.char '=' *> P.notFollowedBy symbolChar *> pure Equals
+ , P.try $ P.char ':' *> P.notFollowedBy symbolChar *> pure Colon
+ , P.try $ P.char '|' *> P.notFollowedBy symbolChar *> pure Pipe
+ , P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot
+ , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi
+ , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At
+ , LName <$> parseLName
+ , do uName <- parseUName
+ (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)
+ , Symbol <$> parseSymbol
+ , StringLiteral <$> parseStringLiteral
+ , Number <$> parseNumber
+ ] <* whitespace
+
+ where
+ parseLName :: P.Parsec String u String
+ parseLName = (:) <$> identStart <*> P.many identLetter
+
+ parseUName :: P.Parsec String u String
+ parseUName = (:) <$> P.upper <*> P.many uidentLetter
+
+ parseSymbol :: P.Parsec String u String
+ parseSymbol = P.many1 symbolChar
+
+ identStart :: P.Parsec String u Char
+ identStart = P.lower <|> P.oneOf "_"
+
+ identLetter :: P.Parsec String u Char
+ identLetter = P.alphaNum <|> P.oneOf "_'"
+
+ uidentLetter :: P.Parsec String u Char
+ uidentLetter = P.alphaNum <|> P.char '_'
+
+ symbolChar :: P.Parsec String u Char
+ symbolChar = P.oneOf opChars
+
+ parseStringLiteral :: P.Parsec String u String
+ parseStringLiteral = blockString <|> PT.stringLiteral tokenParser
+ where
+ delimeter = P.try (P.string "\"\"\"")
+ blockString = delimeter >> P.manyTill P.anyChar delimeter
+
+ parseNumber :: P.Parsec String u (Either Integer Double)
+ parseNumber = (Right <$> P.try (PT.float tokenParser) <|>
+ Left <$> P.try (PT.natural tokenParser)) P.<?> "number"
+
+-- |
+-- We use Text.Parsec.Token to implement the string and number lexemes
+--
+langDef :: PT.GenLanguageDef String u Identity
+langDef = PT.LanguageDef
+ { PT.reservedNames = []
+ , PT.reservedOpNames = []
+ , PT.commentStart = ""
+ , PT.commentEnd = ""
+ , PT.commentLine = ""
+ , PT.nestedComments = True
+ , PT.identStart = fail "Identifiers not supported"
+ , PT.identLetter = fail "Identifiers not supported"
+ , PT.opStart = fail "Operators not supported"
+ , PT.opLetter = fail "Operators not supported"
+ , PT.caseSensitive = True
+ }
+
+-- |
+-- A token parser based on the language definition
+--
+tokenParser :: PT.GenTokenParser String u Identity
+tokenParser = PT.makeTokenParser langDef
+
+type TokenParser a = P.Parsec [PositionedToken] ParseState a
+
+anyToken :: TokenParser PositionedToken
+anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just
+
+token :: (Token -> Maybe a) -> TokenParser a
+token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)
+
+match :: Token -> TokenParser ()
+match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> prettyPrintToken tok
+
+lparen :: TokenParser ()
+lparen = match LParen
+
+rparen :: TokenParser ()
+rparen = match RParen
+
+parens :: TokenParser a -> TokenParser a
+parens = P.between lparen rparen
+
+lbrace :: TokenParser ()
+lbrace = match LBrace
+
+rbrace :: TokenParser ()
+rbrace = match RBrace
+
+braces :: TokenParser a -> TokenParser a
+braces = P.between lbrace rbrace
+
+lsquare :: TokenParser ()
+lsquare = match LSquare
+
+rsquare :: TokenParser ()
+rsquare = match RSquare
+
+squares :: TokenParser a -> TokenParser a
+squares = P.between lsquare rsquare
+
+indent :: TokenParser Int
+indent = token go P.<?> "indentation"
+ where
+ go (Indent n) = Just n
+ go _ = Nothing
+
+indentAt :: P.Column -> TokenParser ()
+indentAt n = token go P.<?> "indentation at level " ++ show n
+ where
+ go (Indent n') | n == n' = Just ()
+ go _ = Nothing
+
+larrow :: TokenParser ()
+larrow = match LArrow
+
+rarrow :: TokenParser ()
+rarrow = match RArrow
+
+lfatArrow :: TokenParser ()
+lfatArrow = match LFatArrow
+
+rfatArrow :: TokenParser ()
+rfatArrow = match RFatArrow
+
+colon :: TokenParser ()
+colon = match Colon
+
+doubleColon :: TokenParser ()
+doubleColon = match DoubleColon
+
+equals :: TokenParser ()
+equals = match Equals
+
+pipe :: TokenParser ()
+pipe = match Pipe
+
+tick :: TokenParser ()
+tick = match Tick
+
+dot :: TokenParser ()
+dot = match Dot
+
+comma :: TokenParser ()
+comma = match Comma
+
+semi :: TokenParser ()
+semi = match Semi
+
+at :: TokenParser ()
+at = match At
+
+-- |
+-- Parse zero or more values separated by semicolons
+--
+semiSep :: TokenParser a -> TokenParser [a]
+semiSep = flip P.sepBy semi
+
+-- |
+-- Parse one or more values separated by semicolons
+--
+semiSep1 :: TokenParser a -> TokenParser [a]
+semiSep1 = flip P.sepBy1 semi
+
+-- |
+-- Parse zero or more values separated by commas
+--
+commaSep :: TokenParser a -> TokenParser [a]
+commaSep = flip P.sepBy comma
+
+-- |
+-- Parse one or more values separated by commas
+--
+commaSep1 :: TokenParser a -> TokenParser [a]
+commaSep1 = flip P.sepBy1 comma
+
+lname :: TokenParser String
+lname = token go P.<?> "identifier"
+ where
+ go (LName s) = Just s
+ go _ = Nothing
+
+qualifier :: TokenParser String
+qualifier = token go P.<?> "qualifier"
+ where
+ go (Qualifier s) = Just s
+ go _ = Nothing
+
+reserved :: String -> TokenParser ()
+reserved s = token go P.<?> show s
+ where
+ go (LName s') | s == s' = Just ()
+ go _ = Nothing
+
+uname :: TokenParser String
+uname = token go P.<?> "proper name"
+ where
+ go (UName s) = Just s
+ go _ = Nothing
+
+mname :: TokenParser String
+mname = token go P.<?> "module name"
+ where
+ go (UName s) | validModuleName s = Just s
+ go _ = Nothing
+
+uname' :: String -> TokenParser ()
+uname' s = token go P.<?> show s
+ where
+ go (UName s') | s == s' = Just ()
+ go _ = Nothing
+
+symbol :: TokenParser String
+symbol = token go P.<?> "symbol"
+ where
+ go (Symbol s) = Just s
+ go Colon = Just ":"
+ go LFatArrow = Just "<="
+ go _ = Nothing
+
+symbol' :: String -> TokenParser ()
+symbol' s = token go P.<?> show s
+ where
+ go (Symbol s') | s == s' = Just ()
+ go Colon | s == ":" = Just ()
+ go LFatArrow | s == "<=" = Just ()
+ go _ = Nothing
+
+stringLiteral :: TokenParser String
+stringLiteral = token go P.<?> "string literal"
+ where
+ go (StringLiteral s) = Just s
+ go _ = Nothing
+
+number :: TokenParser (Either Integer Double)
+number = token go P.<?> "number"
+ where
+ go (Number n) = Just n
+ go _ = Nothing
+
+natural :: TokenParser Integer
+natural = token go P.<?> "natural"
+ where
+ go (Number (Left n)) = Just n
+ go _ = Nothing
+
+identifier :: TokenParser String
+identifier = token go P.<?> "identifier"
+ where
+ go (LName s) | s `notElem` reservedPsNames = Just s
+ go _ = Nothing
+
+validModuleName :: String -> Bool
+validModuleName s = not ('_' `elem` s)
+
+-- |
+-- A list of purescript reserved identifiers
+--
+reservedPsNames :: [String]
+reservedPsNames = [ "data"
+ , "newtype"
+ , "type"
+ , "foreign"
+ , "import"
+ , "infixl"
+ , "infixr"
+ , "infix"
+ , "class"
+ , "instance"
+ , "module"
+ , "case"
+ , "of"
+ , "if"
+ , "then"
+ , "else"
+ , "do"
+ , "let"
+ , "true"
+ , "false"
+ , "in"
+ , "where"
+ ]
+
+reservedTypeNames :: [String]
+reservedTypeNames = [ "forall", "where" ]
+
+-- |
+-- The characters allowed for use in operators
+--
+opChars :: [Char]
+opChars = ":!#$%&*+./<=>?@\\^|-~"
+
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 3dab411..06e5b85 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -24,46 +24,46 @@ import Control.Applicative
import Control.Monad (when, unless)
import Language.PureScript.Types
-import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Kinds
+import Language.PureScript.Parser.Lexer
import Language.PureScript.Environment
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
-parseArray :: P.Parsec String ParseState Type
+parseArray :: TokenParser Type
parseArray = squares $ return tyArray
-parseArrayOf :: P.Parsec String ParseState Type
+parseArrayOf :: TokenParser Type
parseArrayOf = squares $ TypeApp tyArray <$> parseType
-parseFunction :: P.Parsec String ParseState Type
-parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction
+parseFunction :: TokenParser Type
+parseFunction = parens $ rarrow >> return tyFunction
-parseObject :: P.Parsec String ParseState Type
+parseObject :: TokenParser Type
parseObject = braces $ TypeApp tyObject <$> parseRow
-parseTypeWildcard :: P.Parsec String ParseState Type
-parseTypeWildcard = lexeme (P.char '_') >> return TypeWildcard
+parseTypeWildcard :: TokenParser Type
+parseTypeWildcard = reserved "_" >> return TypeWildcard
-parseTypeVariable :: P.Parsec String ParseState Type
+parseTypeVariable :: TokenParser Type
parseTypeVariable = do
ident <- identifier
when (ident `elem` reservedTypeNames) $ P.unexpected ident
return $ TypeVar ident
-parseTypeConstructor :: P.Parsec String ParseState Type
+parseTypeConstructor :: TokenParser Type
parseTypeConstructor = TypeConstructor <$> parseQualified properName
-parseForAll :: P.Parsec String ParseState Type
+parseForAll :: TokenParser Type
parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
<*> parseConstrainedType
-- |
-- Parse a type as it appears in e.g. a data constructor
--
-parseTypeAtom :: P.Parsec String ParseState Type
+parseTypeAtom :: TokenParser Type
parseTypeAtom = indented *> P.choice (map P.try
[ parseArray
, parseArrayOf
@@ -76,7 +76,7 @@ parseTypeAtom = indented *> P.choice (map P.try
, parens parseRow
, parens parsePolyType ])
-parseConstrainedType :: P.Parsec String ParseState Type
+parseConstrainedType :: TokenParser Type
parseConstrainedType = do
constraints <- P.optionMaybe . P.try $ do
constraints <- parens . commaSep1 $ do
@@ -84,24 +84,24 @@ parseConstrainedType = do
indented
ty <- P.many parseTypeAtom
return (className, ty)
- _ <- lexeme $ P.string "=>"
+ _ <- rfatArrow
return constraints
indented
ty <- parseType
return $ maybe ty (flip ConstrainedType ty) constraints
-parseAnyType :: P.Parsec String ParseState Type
+parseAnyType :: TokenParser Type
parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
where
operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
- , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]
- postfixTable = [ \t -> KindedType t <$> (P.try (lexeme (indented *> P.string "::")) *> parseKind)
+ , [ P.Infix (rarrow >> return function) P.AssocRight ] ]
+ postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind)
]
-- |
-- Parse a monotype
--
-parseType :: P.Parsec String ParseState Type
+parseType :: TokenParser Type
parseType = do
ty <- parseAnyType
unless (isMonoType ty) $ P.unexpected "polymorphic type"
@@ -110,23 +110,25 @@ parseType = do
-- |
-- Parse a polytype
--
-parsePolyType :: P.Parsec String ParseState Type
+parsePolyType :: TokenParser Type
parsePolyType = parseAnyType
-- |
-- Parse an atomic type with no wildcards
--
-noWildcards :: P.Parsec String ParseState Type -> P.Parsec String ParseState Type
+noWildcards :: TokenParser Type -> TokenParser Type
noWildcards p = do
ty <- p
when (containsWildcards ty) $ P.unexpected "type wildcard"
return ty
-parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)
-parseNameAndType p = (,) <$> (indented *> (identifierName <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p
+parseNameAndType :: TokenParser t -> TokenParser (String, t)
+parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p
-parseRowEnding :: P.Parsec String ParseState Type
-parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
+parseRowEnding :: TokenParser Type
+parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> P.choice (map P.try
+ [ parseTypeWildcard
+ , TypeVar <$> identifier ])
-parseRow :: P.Parsec String ParseState Type
+parseRow :: TokenParser Type
parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 380d77e..4c11054 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -17,7 +17,7 @@ module Language.PureScript.Pretty.Common where
import Control.Monad.State
import Data.List (intercalate)
-import Language.PureScript.Parser.Common (reservedPsNames, opChars)
+import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)
-- |
-- Wrap a string in parentheses
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index fc4ea0b..4cd7a00 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -17,17 +17,20 @@ module Language.PureScript.Pretty.JS (
prettyPrintJS
) where
-import Language.PureScript.Pretty.Common
-import Language.PureScript.CodeGen.JS (identNeedsEscaping)
-import Language.PureScript.CodeGen.JS.AST
-
import Data.List
import Data.Maybe (fromMaybe)
-import qualified Control.Arrow as A
-import Control.Arrow ((<+>))
-import Control.PatternArrows
+
import Control.Applicative
+import Control.Arrow ((<+>))
import Control.Monad.State
+import Control.PatternArrows
+import qualified Control.Arrow as A
+
+import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.CodeGen.JS.Common
+import Language.PureScript.Pretty.Common
+import Language.PureScript.Comments
+
import Numeric
literals :: Pattern PrinterState JS String
@@ -117,6 +120,32 @@ literals = mkPattern' match
[ return $ lbl ++ ": "
, prettyPrintJS' js
]
+ match (JSComment com js) = fmap concat $ sequence $
+ [ return "\n"
+ , currentIndent
+ , return "/**\n"
+ ] ++
+ map asLine (concatMap commentLines com) ++
+ [ currentIndent
+ , return " */\n"
+ , currentIndent
+ , prettyPrintJS' js
+ ]
+ where
+ commentLines :: Comment -> [String]
+ commentLines (LineComment s) = [s]
+ commentLines (BlockComment s) = lines s
+
+ asLine :: String -> StateT PrinterState Maybe String
+ asLine s = do
+ i <- currentIndent
+ return $ i ++ " * " ++ removeComments s ++ "\n"
+
+ removeComments :: String -> String
+ removeComments ('*' : '/' : s) = removeComments s
+ removeComments (c : s) = c : removeComments s
+
+ removeComments [] = []
match (JSRaw js) = return js
match _ = mzero
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 667a62d..9b6faed 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -81,7 +81,7 @@ literals = mkPattern' match
match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"
match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
match (TypedValue _ val _) = prettyPrintValue' val
- match (PositionedValue _ val) = prettyPrintValue' val
+ match (PositionedValue _ _ val) = prettyPrintValue' val
match _ = mzero
prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
@@ -90,7 +90,7 @@ prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $
[ return $ show ident ++ " = "
, prettyPrintValue' val
]
-prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d
+prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d
prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
@@ -126,7 +126,7 @@ prettyPrintDoNotationElement (DoNotationLet ds) =
[ return "let "
, withIndent $ prettyPrintMany prettyPrintDeclaration ds
]
-prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
+prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el
ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
ifThenElse = mkPattern match
@@ -204,7 +204,7 @@ prettyPrintBinderAtom = mkPattern' match
, return "]"
]
match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
- match (PositionedBinder _ binder) = prettyPrintBinder' binder
+ match (PositionedBinder _ _ binder) = prettyPrintBinder' binder
match _ = mzero
-- |
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 8ea17e4..69e3086 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Renamer
-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
@@ -23,8 +24,7 @@ import Data.List (find)
import qualified Data.Map as M
import qualified Data.Set as S
-import Language.PureScript.AST
-import Language.PureScript.Environment
+import Language.PureScript.CoreFn
import Language.PureScript.Names
import Language.PureScript.Traversals
@@ -100,25 +100,21 @@ lookupIdent name = do
-- |
-- Finds idents introduced by declarations.
--
-findDeclIdents :: [Declaration] -> [Ident]
+findDeclIdents :: [Bind Ann] -> [Ident]
findDeclIdents = concatMap go
where
- go (ValueDeclaration ident _ _ _) = [ident]
- go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds
- go (ExternDeclaration _ ident _ _) = [ident]
- go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds
- go (PositionedDeclaration _ d) = go d
- go _ = []
+ go (NonRec ident _) = [ident]
+ go (Rec ds) = map fst ds
-- |
-- Renames within each declaration in a module.
--
-renameInModules :: [Module] -> [Module]
+renameInModules :: [Module Ann] -> [Module Ann]
renameInModules = map go
where
- go :: Module -> Module
- go (Module mn decls exps) = Module mn (renameInDecl' (findDeclIdents decls) `map` decls) exps
- renameInDecl' :: [Ident] -> Declaration -> Declaration
+ go :: Module Ann -> Module Ann
+ go m@(Module _ _ _ _ decls) = m { moduleDecls = renameInDecl' (findDeclIdents decls) `map` decls }
+ renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann
renameInDecl' scope = runRename scope . renameInDecl True
-- |
@@ -128,65 +124,57 @@ renameInModules = map go
-- been added), whereas in a Let declarations are renamed if their name shadows
-- another in the current scope.
--
-renameInDecl :: Bool -> Declaration -> Rename Declaration
-renameInDecl isTopLevel (ValueDeclaration name nameKind [] (Right val)) = do
+renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)
+renameInDecl isTopLevel (NonRec name val) = do
name' <- if isTopLevel then return name else updateScope name
- ValueDeclaration name' nameKind [] . Right <$> renameInValue val
-renameInDecl isTopLevel (BindingGroupDeclaration ds) = do
+ NonRec name' <$> renameInValue val
+renameInDecl isTopLevel (Rec ds) = do
ds' <- mapM updateNames ds
- BindingGroupDeclaration <$> mapM updateValues ds'
+ Rec <$> mapM updateValues ds'
where
- updateNames :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)
- updateNames (name, nameKind, val) = do
+ updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
+ updateNames (name, val) = do
name' <- if isTopLevel then return name else updateScope name
- return (name', nameKind, val)
- updateValues :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)
- updateValues (name, nameKind, val) =
- (,,) name nameKind <$> renameInValue val
-renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =
- TypeInstanceDeclaration name cs className args <$> mapM (renameInDecl True) ds
-renameInDecl isTopLevel (PositionedDeclaration pos d) =
- PositionedDeclaration pos <$> renameInDecl isTopLevel d
-renameInDecl _ other = return other
+ return (name', val)
+ updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
+ updateValues (name, val) = (,) name <$> renameInValue val
-- |
-- Renames within a value.
--
-renameInValue :: Expr -> Rename Expr
-renameInValue (UnaryMinus v) =
- UnaryMinus <$> renameInValue v
-renameInValue (ArrayLiteral vs) =
- ArrayLiteral <$> mapM renameInValue vs
-renameInValue (ObjectLiteral vs) =
- ObjectLiteral <$> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
-renameInValue (Accessor prop v) =
- Accessor prop <$> renameInValue v
-renameInValue (ObjectUpdate obj vs) =
- ObjectUpdate <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
-renameInValue (Abs (Left name) v) =
- newScope $ Abs . Left <$> updateScope name <*> renameInValue v
-renameInValue (App v1 v2) =
- App <$> renameInValue v1 <*> renameInValue v2
-renameInValue (Var (Qualified Nothing name)) =
- Var . Qualified Nothing <$> lookupIdent name
-renameInValue (IfThenElse v1 v2 v3) =
- IfThenElse <$> renameInValue v1 <*> renameInValue v2 <*> renameInValue v3
-renameInValue (Case vs alts) =
- newScope $ Case <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts
-renameInValue (TypedValue check v ty) =
- TypedValue check <$> renameInValue v <*> pure ty
-renameInValue (Let ds v) =
- newScope $ Let <$> mapM (renameInDecl False) ds <*> renameInValue v
-renameInValue (TypeClassDictionaryConstructorApp name v) =
- TypeClassDictionaryConstructorApp name <$> renameInValue v
-renameInValue (PositionedValue pos v) =
- PositionedValue pos <$> renameInValue v
-renameInValue v = return v
+renameInValue :: Expr Ann -> Rename (Expr Ann)
+renameInValue (Literal ann l) =
+ Literal ann <$> renameInLiteral renameInValue l
+renameInValue c@(Constructor{}) = return c
+renameInValue (Accessor ann prop v) =
+ Accessor ann prop <$> renameInValue v
+renameInValue (ObjectUpdate ann obj vs) =
+ ObjectUpdate ann <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
+renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e
+renameInValue (Abs ann name v) =
+ newScope $ Abs ann <$> updateScope name <*> renameInValue v
+renameInValue (App ann v1 v2) =
+ App ann <$> renameInValue v1 <*> renameInValue v2
+renameInValue (Var ann (Qualified Nothing name)) =
+ Var ann . Qualified Nothing <$> lookupIdent name
+renameInValue v@(Var{}) = return v
+renameInValue (Case ann vs alts) =
+ newScope $ Case ann <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts
+renameInValue (Let ann ds v) =
+ newScope $ Let ann <$> mapM (renameInDecl False) ds <*> renameInValue v
+
+-- |
+-- Renames within literals.
+--
+renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a)
+renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> mapM rename bs
+renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> mapM (sndM rename) bs
+renameInLiteral _ l = return l
-- |
-- Renames within case alternatives.
--
-renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative
+renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)
renameInCaseAlternative (CaseAlternative bs v) =
CaseAlternative <$> mapM renameInBinder bs
<*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v
@@ -194,18 +182,13 @@ renameInCaseAlternative (CaseAlternative bs v) =
-- |
-- Renames within binders.
--
-renameInBinder :: Binder -> Rename Binder
-renameInBinder (VarBinder name) =
- VarBinder <$> updateScope name
-renameInBinder (ConstructorBinder name bs) =
- ConstructorBinder name <$> mapM renameInBinder bs
-renameInBinder (ObjectBinder bs) =
- ObjectBinder <$> mapM (sndM renameInBinder) bs
-renameInBinder (ArrayBinder bs) =
- ArrayBinder <$> mapM renameInBinder bs
-renameInBinder (ConsBinder b1 b2) =
- ConsBinder <$> renameInBinder b1 <*> renameInBinder b2
-renameInBinder (NamedBinder name b) =
- NamedBinder <$> updateScope name <*> renameInBinder b
-renameInBinder (PositionedBinder _ b) = renameInBinder b
-renameInBinder other = return other
+renameInBinder :: Binder a -> Rename (Binder a)
+renameInBinder n@(NullBinder{}) = return n
+renameInBinder (LiteralBinder ann b) =
+ LiteralBinder ann <$> renameInLiteral renameInBinder b
+renameInBinder (VarBinder ann name) =
+ VarBinder ann <$> updateScope name
+renameInBinder (ConstructorBinder ann tctor dctor bs) =
+ ConstructorBinder ann tctor dctor <$> mapM renameInBinder bs
+renameInBinder (NamedBinder ann name b) =
+ NamedBinder ann <$> updateScope name <*> renameInBinder b
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index fe0743a..cf44f3b 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -88,7 +88,7 @@ collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGro
where
go (DataBindingGroupDeclaration ds) = ds
go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
- go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d
+ go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d
go other = [other]
collapseBindingGroupsForValue :: Expr -> Expr
@@ -139,13 +139,13 @@ usedProperNames moduleName =
getIdent :: Declaration -> Ident
getIdent (ValueDeclaration ident _ _ _) = ident
-getIdent (PositionedDeclaration _ d) = getIdent d
+getIdent (PositionedDeclaration _ _ d) = getIdent d
getIdent _ = error "Expected ValueDeclaration"
getProperName :: Declaration -> ProperName
getProperName (DataDeclaration _ pn _ _) = pn
getProperName (TypeSynonymDeclaration pn _ _) = pn
-getProperName (PositionedDeclaration _ d) = getProperName d
+getProperName (PositionedDeclaration _ _ d) = getProperName d
getProperName _ = error "Expected DataDeclaration"
-- |
@@ -178,7 +178,7 @@ toBindingGroup moduleName (CyclicSCC ds') =
toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
cycleError :: Declaration -> [Declaration] -> Either ErrorStack a
- cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d 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 []
@@ -195,11 +195,11 @@ toDataBindingGroup (CyclicSCC ds')
isTypeSynonym :: Declaration -> Maybe ProperName
isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
-isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d
+isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d
isTypeSynonym _ = Nothing
fromValueDecl :: Declaration -> (Ident, NameKind, Expr)
fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)
fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
-fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d
+fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d
fromValueDecl _ = error "Expected ValueDeclaration"
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 5417e2e..842c0fb 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -75,16 +75,16 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro
where
go (Let ds val') = Let <$> desugarCases ds <*> pure val'
go other = return other
- desugarRest (PositionedDeclaration pos d : ds) = do
+ desugarRest (PositionedDeclaration pos com d : ds) = do
(d' : ds') <- desugarRest (d : ds)
- return (PositionedDeclaration pos d' : ds')
+ return (PositionedDeclaration pos com d' : ds')
desugarRest (d : ds) = (:) d <$> desugarRest ds
desugarRest [] = pure []
inSameGroup :: Declaration -> Declaration -> Bool
inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
-inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2
-inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2
+inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2
+inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
inSameGroup _ _ = False
toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
@@ -101,9 +101,9 @@ toDecls ds@(ValueDeclaration ident _ bs result : _) = do
throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing
caseDecl <- makeCaseDeclaration ident tuples
return [caseDecl]
-toDecls (PositionedDeclaration pos d : ds) = do
+toDecls (PositionedDeclaration pos com d : ds) = do
(d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
- return (PositionedDeclaration pos d' : ds')
+ return (PositionedDeclaration pos com d' : ds')
toDecls ds = return ds
isVarBinder :: Binder -> Bool
@@ -112,7 +112,7 @@ isVarBinder _ = False
toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)
toTuple (ValueDeclaration _ _ bs result) = (bs, result)
-toTuple (PositionedDeclaration _ d) = toTuple d
+toTuple (PositionedDeclaration _ _ d) = toTuple d
toTuple _ = error "Not a value declaration"
makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 596a7e1..ac30a39 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -36,7 +36,7 @@ desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts
desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
-desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)
+desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
desugarDo d =
let (f, _, _) = everywhereOnValuesM return replace return
in f d
@@ -49,7 +49,7 @@ desugarDo d =
replace :: Expr -> SupplyT (Either ErrorStack) Expr
replace (Do els) = go els
- replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)
+ replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
replace other = return other
go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr
@@ -71,4 +71,4 @@ desugarDo d =
go (DoNotationLet ds : rest) = do
rest' <- go rest
return $ Let ds rest'
- go (PositionedDoNotationElement pos el : rest) = rethrowWithPosition pos $ PositionedValue pos <$> go (el : rest)
+ go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 917d563..504bb2c 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -199,7 +199,7 @@ renameInModule imports exports (Module mn decls exps) =
(go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Declaration)
- updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)
+ updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)
updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
(,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
@@ -217,7 +217,7 @@ renameInModule imports exports (Module mn decls exps) =
updateDecl s d = return (s, d)
updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)
- updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)
+ updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)
updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
updateValue (pos, bound) (Let ds val') =
let args = mapMaybe letBoundVariable ds
@@ -235,7 +235,7 @@ renameInModule imports exports (Module mn decls exps) =
updateValue s v = return (s, v)
updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Binder)
- updateBinder (_, bound) v@(PositionedBinder pos _) = return ((Just pos, bound), v)
+ updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)
updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
updateBinder s v = return (s, v)
@@ -244,7 +244,7 @@ renameInModule imports exports (Module mn decls exps) =
letBoundVariable :: Declaration -> Maybe Ident
letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
- letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d
+ letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d
letBoundVariable _ = Nothing
updateTypesEverywhere :: Maybe SourceSpan -> Type -> Either ErrorStack Type
@@ -317,14 +317,14 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
foldM go env' ds
where
go env'' (TypeDeclaration name _) = addValue env'' mn name
- go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d
+ go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d
go _ _ = error "Invalid declaration in TypeClassDeclaration"
addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
- addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d
+ addDecl mn env (PositionedDeclaration _ _ d) = addDecl mn env d
addDecl _ env _ = return env
-- |
@@ -349,7 +349,7 @@ filterExports mn exps env = do
-- Ensure the exported types and data constructors exist in the module and add them to the set of
-- exports
filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]
- filterTypes expTys result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterTypes expTys result r
+ filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
filterTypes expTys result (TypeRef name expDcons) = do
dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys
dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
@@ -365,7 +365,7 @@ filterExports mn exps env = do
-- Ensure the exported classes exist in the module and add them to the set of exports
filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]
- filterClasses exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterClasses exps' result r
+ filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r
filterClasses exps' result (TypeClassRef name) =
if name `elem` exps'
then return $ name : result
@@ -374,7 +374,7 @@ filterExports mn exps env = do
-- Ensure the exported values exist in the module and add them to the set of exports
filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]
- filterValues exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterValues exps' result r
+ filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r
filterValues exps' result (ValueRef name) =
if name `elem` exps'
then return $ name : result
@@ -389,7 +389,7 @@ findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclar
findImports = foldl (findImports' Nothing) M.empty
where
findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
- findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d
+ findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d
findImports' _ result _ = result
-- |
@@ -443,7 +443,7 @@ resolveImport currentModule importModule exps imps impQual =
checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
- checkTypeRef (PositionedDeclarationRef _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
+ checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
checkTypeRef _ acc _ = acc
in foldl (checkTypeRef ref) False hidden
isHidden hidden ref = ref `elem` hidden
@@ -457,7 +457,7 @@ resolveImport currentModule importModule exps imps impQual =
-- Import something explicitly
importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
- importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r
+ importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r
importExplicit imp (ValueRef name) = do
values' <- updateImports (importedValues imp) name
return $ imp { importedValues = values' }
@@ -476,7 +476,7 @@ resolveImport currentModule importModule exps imps impQual =
checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]
checkedRefs = mapM check
where
- check (PositionedDeclarationRef pos r) =
+ check (PositionedDeclarationRef pos _ r) =
rethrowWithPosition pos $ check r
check ref@(ValueRef name) =
checkImportExists "value" values name >> return ref
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index fb2cfe8..4582161 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -80,7 +80,7 @@ collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
collectFixities (Module moduleName ds _) = concatMap collect ds
where
collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
- collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
+ collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
collect FixityDeclaration{} = error "Fixity without srcpos info"
collect _ = []
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index e0ea15e..49a8dc9 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -14,11 +14,13 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.Sugar.TypeClasses (
- desugarTypeClasses
-) where
+module Language.PureScript.Sugar.TypeClasses
+ ( desugarTypeClasses
+ , typeClassMemberName
+ , superClassDictionaryNames
+ ) where
-import Language.PureScript.AST
+import Language.PureScript.AST hiding (isExported)
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Kinds
@@ -162,9 +164,9 @@ desugarDecl mn exps = go
desugared <- lift $ desugarCases members
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
return $ (expRef name className tys, [d, dictDecl])
- go (PositionedDeclaration pos d) = do
+ go (PositionedDeclaration pos com d) = do
(dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
- return (dr, map (PositionedDeclaration pos) ds)
+ return (dr, map (PositionedDeclaration pos com) ds)
go other = return (Nothing, [other])
expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
@@ -195,16 +197,15 @@ desugarDecl mn exps = go
memberToNameAndType :: Declaration -> (Ident, Type)
memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
-memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
+memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d
memberToNameAndType _ = error "Invalid declaration in type class definition"
-typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration
+typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration
typeClassDictionaryDeclaration name args implies members =
- let superclassTypes = [ (fieldName, function unit tySynApp)
- | (index, (superclass, tyArgs)) <- zip [0..] implies
- , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
- , let fieldName = mkSuperclassDictionaryName superclass index
- ]
+ let superclassTypes = superClassDictionaryNames implies `zip`
+ [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)
+ | (superclass, tyArgs) <- implies
+ ]
members' = map (first runIdent . memberToNameAndType) members
mtys = members' ++ superclassTypes
in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
@@ -214,17 +215,14 @@ 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))
-typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
- PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
+typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
+ PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
-mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String
-mkSuperclassDictionaryName pn index = C.__superclass_ ++ show pn ++ "_" ++ show index
-
unit :: Type
unit = TypeApp tyObject REmpty
-typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
+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
m <- get
@@ -242,46 +240,51 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
-- Replace the type arguments with the appropriate types in the member types
let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
+
-- Create values for the type instance members
- memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls
+ members <- zip (map typeClassMemberName decls) <$> mapM (memberToValue memberTypes) decls
+
-- Create the type of the dictionary
-- The type is an object type, but depending on type instance dependencies, may be constrained.
-- The dictionary itself is an object literal.
- let superclasses =
- [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))
- | (index, (superclass, suTyArgs)) <- zip [0..] implies
+ let superclasses = superClassDictionaryNames implies `zip`
+ [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)
+ | (superclass, suTyArgs) <- implies
, let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
- , let fieldName = mkSuperclassDictionaryName superclass index
]
- let memberNames' = ObjectLiteral (memberNames ++ superclasses)
+ let props = ObjectLiteral (members ++ superclasses)
dictTy = foldl TypeApp (TypeConstructor className) tys
constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
- dict = TypeClassDictionaryConstructorApp className memberNames'
+ dict = TypeClassDictionaryConstructorApp className props
result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))
return result
where
declName :: Declaration -> Maybe Ident
- declName (PositionedDeclaration _ d) = declName d
+ declName (PositionedDeclaration _ _ d) = declName d
declName (ValueDeclaration ident _ _ _) = Just ident
declName (TypeDeclaration ident _) = Just ident
declName _ = Nothing
- memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)
- memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _) = do
+ memberToValue :: [(Ident, Type)] -> Declaration -> Desugar Expr
+ memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
_ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
- let memberValue = typeInstanceDictionaryEntryValue d
- return (ident, memberValue)
- memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
- (ident, val) <- memberToNameAndValue tys' d
- return (ident, PositionedValue pos val)
- memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
-
- typeInstanceDictionaryEntryValue :: Declaration -> Expr
- typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] (Right val)) = val
- typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
- typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"
-
-
+ return val
+ memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do
+ val <- memberToValue tys' d
+ return (PositionedValue pos com val)
+ memberToValue _ _ = error "Invalid declaration in type instance definition"
+
+typeClassMemberName :: Declaration -> String
+typeClassMemberName (TypeDeclaration ident _) = runIdent ident
+typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident
+typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d
+typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d
+
+superClassDictionaryNames :: [Constraint] -> [String]
+superClassDictionaryNames supers =
+ [ C.__superclass_ ++ show pn ++ "_" ++ show (index :: Integer)
+ | (index, (pn, _)) <- zip [0..] supers
+ ]
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 31b6a07..aa4427e 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -43,18 +43,18 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->
-- Replace all top level type declarations with type annotations
--
desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]
-desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do
+desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
(d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
- return (PositionedDeclaration pos d' : ds')
+ return (PositionedDeclaration pos com d' : ds')
desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
(_, nameKind, val) <- fromValueDeclaration d
desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
where
fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)
fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
- fromValueDeclaration (PositionedDeclaration pos d') = do
+ fromValueDeclaration (PositionedDeclaration pos com d') = do
(ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
- return (ident, nameKind, PositionedValue pos val)
+ return (ident, nameKind, PositionedValue pos com val)
fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index d0e06b1..adcbb73 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -78,13 +78,13 @@ addValue moduleName name ty nameKind = do
env <- getEnv
putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
-addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
+addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Check ()
addTypeClass moduleName pn args implies ds =
let members = map toPair ds in
modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
where
toPair (TypeDeclaration ident ty) = (ident, ty)
- toPair (PositionedDeclaration _ d) = toPair d
+ toPair (PositionedDeclaration _ _ d) = toPair d
toPair _ = error "Invalid declaration in TypeClassDeclaration"
addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
@@ -163,10 +163,10 @@ typeCheckAll mainModuleName moduleName exps = go
return $ d : ds
where
toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
- toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'
+ toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
toTypeSynonym _ = Nothing
toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
- toDataDecl (PositionedDeclaration _ d') = toDataDecl d'
+ toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
toDataDecl _ = Nothing
go (TypeSynonymDeclaration name args ty : rest) = do
rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
@@ -235,28 +235,32 @@ typeCheckAll mainModuleName moduleName exps = go
addTypeClass moduleName pn args implies tys
ds <- go rest
return $ d : ds
- go (TypeInstanceDeclaration dictName deps className tys _ : rest) =
- go (ExternInstanceDeclaration dictName deps className tys : rest)
+ go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
+ goInstance d dictName deps className tys rest
go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
+ goInstance d dictName deps className tys rest
+ go (PositionedDeclaration pos com d : rest) =
+ rethrowWithPosition pos $ do
+ (d' : rest') <- go (d : rest)
+ return (PositionedDeclaration pos com d' : rest')
+ goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]
+ goInstance d dictName deps className tys rest = do
mapM_ (checkTypeClassInstance moduleName) tys
forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]
ds <- go rest
return $ d : ds
+
where
+
isInstanceExported :: Bool
isInstanceExported = any exportsInstance exps
exportsInstance :: DeclarationRef -> Bool
exportsInstance (TypeInstanceRef name) | name == dictName = True
- exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r
+ exportsInstance (PositionedDeclarationRef _ _ r) = exportsInstance r
exportsInstance _ = False
- go (PositionedDeclaration pos d : rest) =
- rethrowWithPosition pos $ do
- (d' : rest') <- go (d : rest)
- return (PositionedDeclaration pos d' : rest')
-
-- |
-- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
-- extracted from the kind of the type constructor itself.
@@ -342,10 +346,10 @@ typeCheckModule mainModuleName (Module mn decls (Just exps)) = do
runValueRef _ = error "non-ValueRef passed to runValueRef"
findClassMembers :: Declaration -> Maybe [Ident]
findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
- findClassMembers (PositionedDeclaration _ d) = findClassMembers d
+ findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
findClassMembers _ = Nothing
extractMemberName :: Declaration -> Ident
- extractMemberName (PositionedDeclaration _ d) = extractMemberName d
+ extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
extractMemberName (TypeDeclaration memberName _) = memberName
extractMemberName _ = error "Unexpected declaration in typeclass member list"
checkClassMembersAreExported _ = return ()
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 89e94ac..377d3d2 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -64,7 +64,7 @@ data DictionaryValue
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
-- return a type class dictionary reference.
--
-entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr
+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
where
sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
@@ -107,7 +107,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
-- Create dictionaries for subgoals which still need to be solved by calling go recursively
-- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
-- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
- solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> [Maybe [DictionaryValue]]
solveSubgoals _ Nothing = return Nothing
solveSubgoals subst (Just subgoals) = do
dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 2a71eab..b46bbc4 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -296,7 +296,7 @@ infer' (TypedValue checkType val ty) = do
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
val' <- if checkType then check val ty' else return val
return $ TypedValue True val' ty'
-infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val
+infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val
infer' _ = error "Invalid argument to infer"
inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)
@@ -322,9 +322,9 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
-inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
+inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do
(d' : ds', val') <- inferLetBinding seen (d : ds) ret j
- return (PositionedDeclaration pos d' : ds', val')
+ return (PositionedDeclaration pos com d' : ds', val')
inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"
-- |
@@ -394,7 +394,7 @@ inferBinder val (ConsBinder headBinder tailBinder) = do
inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
return $ M.insert name val m
-inferBinder val (PositionedBinder pos binder) =
+inferBinder val (PositionedBinder pos _ binder) =
rethrowWithPosition pos $ inferBinder val binder
-- |
@@ -563,7 +563,7 @@ check' val kt@(KindedType ty kind) = do
guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
val' <- check' val ty
return $ TypedValue True val' kt
-check' (PositionedValue pos val) ty =
+check' (PositionedValue pos _ val) ty =
rethrowWithPosition pos $ check val ty
check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index d105eb6..1cf5bba 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -41,7 +41,7 @@ data TypeClassDictionaryInScope
-- |
-- Type class dependencies which must be satisfied to construct this dictionary
--
- , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]
+ , tcdDependencies :: Maybe [Constraint]
-- |
-- The type of this dictionary
--
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 9a071e9..528527e 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -69,7 +69,7 @@ data Type
-- |
-- A type with a set of type class constraints
--
- | ConstrainedType [(Qualified ProperName, [Type])] Type
+ | ConstrainedType [Constraint] Type
-- |
-- A skolem constant
--
@@ -84,7 +84,7 @@ data Type
| RCons String Type Type
-- |
-- A type with a kind annotation
- --
+ --
| KindedType Type Kind
--
-- |
@@ -105,6 +105,11 @@ data Type
| PrettyPrintForAll [String] Type deriving (Show, Eq, Data, Typeable)
-- |
+-- A typeclass constraint
+--
+type Constraint = (Qualified ProperName, [Type])
+
+-- |
-- Convert a row to a list of pairs of labels and types
--
rowToList :: Type -> ([(String, Type)], Type)
@@ -144,9 +149,9 @@ replaceTypeVars v r = replaceAllTypeVars [(v, r)]
replaceAllTypeVars :: [(String, Type)] -> Type -> Type
replaceAllTypeVars = go []
where
-
+
go :: [String] -> [(String, Type)] -> Type -> Type
- go _ m (TypeVar v) =
+ go _ m (TypeVar v) =
case v `lookup` m of
Just r -> r
Nothing -> TypeVar v
@@ -165,7 +170,7 @@ replaceAllTypeVars = go []
go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)
go bs m (KindedType t k) = KindedType (go bs m t) k
go _ _ ty = ty
-
+
genName orig inUse = try 0
where
try :: Integer -> String