From b25292658ff5f36734735a428763d43c4b2abc19 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Sun, 30 Apr 2023 20:41:50 +0800 Subject: [PATCH 1/2] Initial work on interval trees --- play/Main.hs | 8 ++ purescript.cabal | 9 ++ src/Language/PureScript/AST/SourcePos.hs | 9 ++ src/Language/PureScript/Interface/Types.hs | 110 ++++++++++++++++++ .../PureScript/Sugar/TypeDeclarations.hs | 16 +-- 5 files changed, 144 insertions(+), 8 deletions(-) create mode 100644 play/Main.hs create mode 100644 src/Language/PureScript/Interface/Types.hs diff --git a/play/Main.hs b/play/Main.hs new file mode 100644 index 0000000000..9f124d8182 --- /dev/null +++ b/play/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Protolude + +import Language.PureScript.Interface.Types qualified as P + +main :: IO () +main = P.main diff --git a/purescript.cabal b/purescript.cabal index 383264482d..90b38d4d83 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -190,6 +190,7 @@ common defaults parallel >=3.2.2.0 && <3.3, parsec >=3.1.15.0 && <3.2, pattern-arrows >=0.0.2 && <0.1, + pretty-simple >=4.1.2.0 && <5, process ==1.6.13.1, protolude >=0.3.1 && <0.4, regex-tdfa >=1.3.1.2 && <1.4, @@ -326,6 +327,7 @@ library Language.PureScript.Interactive.Parser Language.PureScript.Interactive.Printer Language.PureScript.Interactive.Types + Language.PureScript.Interface.Types Language.PureScript.Label Language.PureScript.Linter Language.PureScript.Linter.Exhaustive @@ -396,6 +398,13 @@ library autogen-modules: Paths_purescript +executable play + import: defaults + hs-source-dirs: play + main-is: Main.hs + build-depends: + purescript + executable purs import: defaults hs-source-dirs: app diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 262d44b6a1..37b81dab25 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -114,5 +114,14 @@ widenSourceSpan (SourceSpan n1 s1 e1) (SourceSpan n2 s2 e2) = n | n1 == "" = n2 | otherwise = n1 +containsSpan :: SourceSpan -> SourceSpan -> Bool +containsSpan i o = (spanStart i <= spanStart o) && (spanEnd i >= spanEnd o) + +rightOf :: SourceSpan -> SourceSpan -> Bool +rightOf i o = spanStart i >= spanEnd o + +leftOf :: SourceSpan -> SourceSpan -> Bool +leftOf i o = spanEnd i <= spanStart o + widenSourceAnn :: SourceAnn -> SourceAnn -> SourceAnn widenSourceAnn (s1, _) (s2, _) = (widenSourceSpan s1 s2, []) diff --git a/src/Language/PureScript/Interface/Types.hs b/src/Language/PureScript/Interface/Types.hs new file mode 100644 index 0000000000..0702a91f3e --- /dev/null +++ b/src/Language/PureScript/Interface/Types.hs @@ -0,0 +1,110 @@ +module Language.PureScript.Interface.Types where + +import Protolude + +import Control.Monad.Supply (evalSupplyT) +import Control.Monad.Trans.Writer (WriterT(..)) +import Language.PureScript.AST.Declarations (importPrim, getModuleDeclarations, Expr (..), Declaration, pattern ValueDecl, pattern MkUnguarded) +import Language.PureScript.AST.SourcePos (SourceSpan (..), containsSpan, leftOf, rightOf) +import Language.PureScript.AST.Traversals (everythingOnValues) +import Language.PureScript.Crash (internalError) +import Language.PureScript.CST (parseFromFile) +import Language.PureScript.Environment (initEnvironment) +import Language.PureScript.Sugar (desugar) +import Language.PureScript.Sugar.Names.Env (primEnv) +import Language.PureScript.TypeChecker (typeCheckModule, emptyCheckState, debugType) +import Text.Pretty.Simple (pPrint) +import Data.String (String) + +data NodeContext = DeclarationNode | ExpressionNode + deriving (Show) + +data NodeInfo a = NodeInfo + { nodeType :: a + , nodeContext :: NodeContext + } deriving (Show) + +data InterfaceAST a = InterfaceNode + { nodeInfo :: NodeInfo a + , nodeSpan :: SourceSpan, + nodeLeaves :: [InterfaceAST a] + } deriving (Show) + +makeNode :: NodeInfo a -> SourceSpan -> InterfaceAST a +makeNode i s = InterfaceNode i s [] + +combineAST :: forall a. InterfaceAST a -> InterfaceAST a -> InterfaceAST a +combineAST x@(InterfaceNode xInfo xSpan xLeaves) y@(InterfaceNode _ ySpan yLeaves) + -- for same spans, just merge the leaves + | xSpan == ySpan = InterfaceNode xInfo xSpan (mergeASTs xLeaves yLeaves) + -- if x contains y, then flip the arguments + | xSpan `containsSpan` ySpan = combineAST y x + -- at this point, we can just insert y into x +combineAST y (InterfaceNode xInfo xSpan xLeaves) = InterfaceNode xInfo xSpan (insertAST y xLeaves) + +insertAST :: forall a. InterfaceAST a -> [InterfaceAST a] -> [InterfaceAST a] +insertAST x = mergeASTs [x] + +mergeASTs :: forall a. [InterfaceAST a] -> [InterfaceAST a] -> [InterfaceAST a] +mergeASTs xs [] = xs +mergeASTs [] ys = ys +mergeASTs xs@(x : xr) ys@(y : yr) + -- x contains y, insert y to x + | xSpan `containsSpan` ySpan = mergeASTs (combineAST x y : xr) yr + -- y contains x, insert x to y + | ySpan `containsSpan` xSpan = mergeASTs xr (combineAST x y : yr) + -- x comes after y + | xSpan `rightOf` ySpan = y : mergeASTs xs yr + -- y comes after x + | xSpan `leftOf` ySpan = x : mergeASTs xr ys + -- fully disjoint, just recurse + | otherwise = x : mergeASTs xr ys + where + xSpan :: SourceSpan + xSpan = nodeSpan x + + ySpan :: SourceSpan + ySpan = nodeSpan y + +source :: Text +source = unlines + [ "module Main where" + , "values :: Array Int" + , "values = [0, 1]" + ] + +main :: IO () +main = do + case snd $ parseFromFile "" source of + Left _ -> internalError "Could not parse file." + Right parsedModule -> do + checkResult <- runExceptT $ fmap fst $ runWriterT $ evalSupplyT 0 $ do + (desugardModule, (externsEnv, _)) <- runStateT (desugar [] (importPrim parsedModule)) (primEnv, mempty) + let moduleExports = (\(_, _, exports) -> exports) <$> externsEnv + evalStateT (typeCheckModule moduleExports desugardModule) (emptyCheckState initEnvironment) + case checkResult of + Left _ -> internalError "Could not check file." + Right checkedModule' -> + forM_ (concatMap declarationToAST $ getModuleDeclarations checkedModule') $ \i -> + pPrint i + + where + declarationToAST :: Declaration -> [InterfaceAST String] + (declarationToAST, _, _, _, _) = everythingOnValues mergeASTs onDecl onExpr noAST noAST noAST + where + noAST :: forall a. a -> [InterfaceAST String] + noAST = const [] + + onDecl :: Declaration -> [InterfaceAST String] + onDecl = \case + ValueDecl (s, _) _ _ _ [MkUnguarded (TypedValue _ (PositionedValue _ _ _) t)] -> + [ makeNode (NodeInfo (debugType t) DeclarationNode) s ] + _ -> + [] + + onExpr :: Expr -> [InterfaceAST String] + onExpr = \case + TypedValue _ (PositionedValue s _ _) t -> + [ makeNode (NodeInfo (debugType t) ExpressionNode) s ] + _ -> + [] diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index ef00748d67..2826036342 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -11,8 +11,8 @@ import Prelude import Control.Monad (unless) import Control.Monad.Error.Class (MonadError(..)) -import Language.PureScript.AST (Declaration(..), ErrorMessageHint(..), Expr(..), GuardedExpr(..), KindSignatureFor(..), pattern MkUnguarded, Module(..), RoleDeclarationData(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, declSourceSpan, everywhereOnValuesTopDownM) -import Language.PureScript.Names (Ident, coerceProperName) +import Language.PureScript.AST (Declaration(..), ErrorMessageHint(..), Expr(..), GuardedExpr(..), KindSignatureFor(..), pattern MkUnguarded, Module(..), RoleDeclarationData(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, declSourceSpan, everywhereOnValuesTopDownM, SourceAnn, widenSourceAnn) +import Language.PureScript.Names (coerceProperName) import Language.PureScript.Environment (DataDeclType(..), NameKind) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow) @@ -33,17 +33,17 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = desugarTypeDeclarations :: [Declaration] -> m [Declaration] desugarTypeDeclarations (TypeDeclaration (TypeDeclarationData sa name' ty) : d : rest) = do - (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDecl sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) + (sa', nameKind, val) <- fromValueDeclaration d + desugarTypeDeclarations (ValueDecl (widenSourceAnn sa sa') name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) where - fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDecl _ name'' nameKind [] [MkUnguarded val]) - | name' == name'' = return (name'', nameKind, val) + fromValueDeclaration :: Declaration -> m (SourceAnn, NameKind, Expr) + fromValueDeclaration (ValueDecl sa' name'' nameKind [] [MkUnguarded val]) + | name' == name'' = return (sa', nameKind, val) fromValueDeclaration d' = throwError . errorMessage' (declSourceSpan d') $ OrphanTypeDeclaration name' desugarTypeDeclarations [TypeDeclaration (TypeDeclarationData (ss, _) name' _)] = throwError . errorMessage' ss $ OrphanTypeDeclaration name' - desugarTypeDeclarations (ValueDecl sa name' nameKind bs val : rest) = do + desugarTypeDeclarations (ValueDecl sa@(_, _) name' nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr g e) -> GuardedExpr g <$> f e) (:) <$> (ValueDecl sa name' nameKind bs <$> f' val) From 4d68ebd4002b6d3d53e4b0244aed25b28e9f3b1e Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Tue, 2 May 2023 01:19:10 +0800 Subject: [PATCH 2/2] save work --- src/Language/PureScript/Interface/Types.hs | 32 +++++++++++++++----- src/Language/PureScript/TypeChecker/Types.hs | 7 +++-- 2 files changed, 28 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Interface/Types.hs b/src/Language/PureScript/Interface/Types.hs index 0702a91f3e..f4a7f00e3f 100644 --- a/src/Language/PureScript/Interface/Types.hs +++ b/src/Language/PureScript/Interface/Types.hs @@ -15,8 +15,13 @@ import Language.PureScript.Sugar.Names.Env (primEnv) import Language.PureScript.TypeChecker (typeCheckModule, emptyCheckState, debugType) import Text.Pretty.Simple (pPrint) import Data.String (String) +import Language.PureScript.AST.Binders (Binder (..)) +import Debug.Pretty.Simple (pTraceShow) -data NodeContext = DeclarationNode | ExpressionNode +data NodeContext + = DeclarationNode + | BinderNode + | ExpressionNode deriving (Show) data NodeInfo a = NodeInfo @@ -69,8 +74,8 @@ mergeASTs xs@(x : xr) ys@(y : yr) source :: Text source = unlines [ "module Main where" - , "values :: Array Int" - , "values = [0, 1]" + , "values :: Int -> Array Int" + , "values x = [x]" ] main :: IO () @@ -90,17 +95,17 @@ main = do where declarationToAST :: Declaration -> [InterfaceAST String] - (declarationToAST, _, _, _, _) = everythingOnValues mergeASTs onDecl onExpr noAST noAST noAST + (declarationToAST, _, _, _, _) = everythingOnValues mergeASTs onDecl onExpr onBinder noAST noAST where noAST :: forall a. a -> [InterfaceAST String] noAST = const [] onDecl :: Declaration -> [InterfaceAST String] onDecl = \case - ValueDecl (s, _) _ _ _ [MkUnguarded (TypedValue _ (PositionedValue _ _ _) t)] -> - [ makeNode (NodeInfo (debugType t) DeclarationNode) s ] - _ -> - [] + -- ValueDecl (s, _) _ _ _ [MkUnguarded (TypedValue _ (PositionedValue _ _ _) t)] -> + -- [ makeNode (NodeInfo (debugType t) DeclarationNode) s ] + e -> + pTraceShow e [] onExpr :: Expr -> [InterfaceAST String] onExpr = \case @@ -108,3 +113,14 @@ main = do [ makeNode (NodeInfo (debugType t) ExpressionNode) s ] _ -> [] + + onBinder :: Binder -> [InterfaceAST String] + onBinder = \case + TypedBinder t (LiteralBinder s _) -> + [ makeNode (NodeInfo (debugType t) BinderNode) s ] + TypedBinder t (VarBinder s _) -> + [ makeNode (NodeInfo (debugType t) BinderNode) s ] + TypedBinder t (ConstructorBinder s _ _) -> + [ makeNode (NodeInfo (debugType t) BinderNode) s ] + _ -> + [] diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ab532057e8..e6f17e4d75 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -683,8 +683,9 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do guardWith (errorMessage $ OverlappingArgNames Nothing) $ let ns = concatMap binderNames binders in length (ordNub ns) == length ns m1 <- M.unions <$> zipWithM inferBinder nvals binders + let binders' = zipWith TypedBinder nvals binders r <- bindLocalVariables [ (ss, name, ty, Defined) | (name, (ss, ty)) <- M.toList m1 ] $ - CaseAlternative binders <$> forM result (\ge -> checkGuardedRhs ge ret) + CaseAlternative binders' <$> forM result (\ge -> checkGuardedRhs ge ret) rs <- checkBinders nvals ret bs return $ r : rs @@ -707,7 +708,7 @@ checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do | (name, (ss, bty)) <- M.toList variables ] $ checkGuardedRhs (GuardedExpr guards rhs) ret - return $ GuardedExpr (PatternGuard binder (tvToExpr tv) : guards') rhs' + return $ GuardedExpr (PatternGuard (TypedBinder ty binder) (tvToExpr tv) : guards') rhs' -- | -- Check the type of a value, rethrowing errors to provide a better error message @@ -779,7 +780,7 @@ check' (Abs binder ret) ty@(TypeApp _ (TypeApp _ t argTy) retTy) | VarBinder ss arg <- binder = do unifyTypes t tyFunction ret' <- withBindingGroupVisible $ bindLocalVariables [(ss, arg, argTy, Defined)] $ check ret retTy - return $ TypedValue' True (Abs (VarBinder ss arg) (tvToExpr ret')) ty + return $ TypedValue' True (Abs (TypedBinder argTy (VarBinder ss arg)) (tvToExpr ret')) ty | otherwise = internalError "Binder was not desugared" check' (App f arg) ret = do f'@(TypedValue' _ _ ft) <- infer f