├── README.md ├── .gitignore ├── stack.yaml ├── src └── Language │ └── PureScript │ ├── Optimizer │ ├── Types.hs │ ├── Simplify.hs │ ├── CoreAnf.hs │ └── Rename.hs │ └── Optimizer.hs ├── LICENSE ├── package.yaml ├── app └── Main.hs └── purescript-optimizer.cabal /README.md: -------------------------------------------------------------------------------- 1 | # purescript-optimizer 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .DS_Store 3 | bower.json 4 | bower_components 5 | output 6 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.12 2 | packages: 3 | - . 4 | extra-deps: 5 | - network-3.0.1.1 6 | - git: https://github.com/purescript/purescript.git 7 | commit: e0910da84f58b988b1271b2c8e5e926b342c8925 8 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/Types.hs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.Types where 2 | 3 | import Prelude 4 | 5 | import qualified Language.PureScript.AST.SourcePos as Pos 6 | import qualified Language.PureScript.CoreFn as C 7 | import qualified Language.PureScript.Types as T 8 | import Language.PureScript.Optimizer.CoreAnf 9 | 10 | data OptimizerAnn = OptimizerAnn 11 | { annSpan :: Pos.SourceSpan 12 | , annType :: Maybe T.SourceType 13 | , annMeta :: Maybe C.Meta 14 | , annArity :: Int 15 | } 16 | 17 | optAnn :: C.Ann -> OptimizerAnn 18 | optAnn (ss, _, ty, meta) = OptimizerAnn ss ty meta 0 19 | 20 | data OptimizerResult = OptimizerResult 21 | { optModule :: Module OptimizerAnn 22 | } 23 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer.hs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer where 2 | 3 | import Prelude 4 | 5 | import Data.Map (Map) 6 | import qualified Language.PureScript.CoreFn as C 7 | import qualified Language.PureScript.Names as N 8 | import Language.PureScript.Optimizer.CoreAnf 9 | import Language.PureScript.Optimizer.Simplify 10 | import Language.PureScript.Optimizer.Rename 11 | import Language.PureScript.Optimizer.Types 12 | 13 | optimize 14 | :: Map N.ModuleName OptimizerResult 15 | -> C.Module C.Ann 16 | -> OptimizerResult 17 | optimize deps cfnMod = 18 | OptimizerResult $ anfMod { modDecls = modDecls' } 19 | where 20 | deps' = optModule <$> deps 21 | anfMod = renameModule deps' cfnMod 22 | modDecls' = fmap (fmap declFn) . modDecls $ anfMod 23 | 24 | declFn = \case 25 | DeclExpr ns expr -> 26 | DeclExpr ns . reassociate $ expr 27 | decl -> 28 | decl 29 | 30 | 31 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/Simplify.hs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.Simplify where 2 | 3 | import Prelude 4 | 5 | import qualified Data.DList as D 6 | import Data.Foldable (foldl') 7 | import Language.PureScript.Optimizer.CoreAnf 8 | import Lens.Micro ((^.)) 9 | 10 | reassociate :: Expr a -> Expr a 11 | reassociate = run 12 | where 13 | run expr = 14 | stop (expr ^. exprAnn) . go D.empty $ expr 15 | 16 | stop ann (acc, expr) = 17 | case D.toList acc of 18 | [] -> expr 19 | bs -> Let ann bs expr 20 | 21 | go acc = \case 22 | Let ann bs expr -> do 23 | let 24 | bindingFn x = \case 25 | NonRec a b c -> do 26 | let 27 | (x', c') = 28 | go x c 29 | D.snoc x' $ NonRec a b c' 30 | Rec bs' -> do 31 | D.snoc x 32 | . Rec 33 | . fmap (fmap run) 34 | $ bs' 35 | go (foldl' bindingFn acc bs) expr 36 | Abs ann ns expr -> 37 | (acc, Abs ann ns . run $ expr) 38 | Case ann ns alts -> do 39 | let 40 | altFn (CaseAlternative bs res) = do 41 | let 42 | res' = case res of 43 | Guarded gs -> 44 | Guarded . fmap (\(a, b) -> (run a, run b)) $ gs 45 | Unguarded g -> 46 | Unguarded . run $ g 47 | CaseAlternative bs res' 48 | (acc, Case ann ns . fmap altFn $ alts) 49 | expr -> 50 | (acc, expr) 51 | 52 | 53 | 54 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Nathan Faubion (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: purescript-optimizer 2 | version: 0.1.0.0 3 | github: "natefaubion/purescript-optimizer" 4 | license: BSD3 5 | author: "Nathan Faubion" 6 | copyright: "2019 Nathan Faubion" 7 | 8 | extra-source-files: 9 | - README.md 10 | 11 | default-extensions: 12 | - AutoDeriveTypeable 13 | - BangPatterns 14 | - BinaryLiterals 15 | - ConstraintKinds 16 | - DataKinds 17 | - DefaultSignatures 18 | - DeriveDataTypeable 19 | - DeriveFoldable 20 | - DeriveFunctor 21 | - DeriveGeneric 22 | - DeriveTraversable 23 | - DoAndIfThenElse 24 | - EmptyDataDecls 25 | - ExistentialQuantification 26 | - FlexibleContexts 27 | - FlexibleInstances 28 | - FunctionalDependencies 29 | - GADTs 30 | - GeneralizedNewtypeDeriving 31 | - InstanceSigs 32 | - KindSignatures 33 | - LambdaCase 34 | - MultiParamTypeClasses 35 | - MultiWayIf 36 | - NamedFieldPuns 37 | - NoImplicitPrelude 38 | - OverloadedStrings 39 | - PartialTypeSignatures 40 | - PatternGuards 41 | - PolyKinds 42 | - RankNTypes 43 | - RecordWildCards 44 | - ScopedTypeVariables 45 | - StandaloneDeriving 46 | - TupleSections 47 | - TypeFamilies 48 | - TypeOperators 49 | - TypeSynonymInstances 50 | - ViewPatterns 51 | 52 | ghc-options: 53 | - -Wall 54 | - -Wcompat 55 | - -Wincomplete-record-updates 56 | - -Wincomplete-uni-patterns 57 | - -Wmissing-methods 58 | - -Wredundant-constraints 59 | 60 | # Metadata used when publishing your package 61 | # synopsis: Short description of your package 62 | # category: Web 63 | 64 | # To avoid duplicated efforts in documentation and dealing with the 65 | # complications of embedding Haddock markup inside cabal files, it is 66 | # common to point users to the README.md file. 67 | description: Please see the README on GitHub at 68 | 69 | dependencies: 70 | - base 71 | - async 72 | - text 73 | - containers 74 | - unordered-containers 75 | - hashable 76 | - purescript 77 | - Glob 78 | - mtl 79 | - transformers 80 | - prettyprinter 81 | - microlens 82 | - dlist 83 | 84 | library: 85 | source-dirs: src 86 | 87 | executables: 88 | purescript-optimizer-exe: 89 | main: Main.hs 90 | source-dirs: app 91 | ghc-options: 92 | - -threaded 93 | - -rtsopts 94 | - -with-rtsopts=-N 95 | dependencies: 96 | - purescript-optimizer 97 | 98 | tests: 99 | purescript-optimizer-test: 100 | main: Main.hs 101 | source-dirs: test 102 | ghc-options: 103 | - -threaded 104 | - -rtsopts 105 | - -with-rtsopts=-N 106 | dependencies: 107 | - purescript-optimizer 108 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | import Control.Concurrent.Async (forConcurrently) 5 | import Control.Concurrent.MVar 6 | import Control.Monad (join, when) 7 | import Control.Monad.IO.Class (liftIO) 8 | import Control.Monad.Trans (lift) 9 | import Data.Foldable (for_, foldl') 10 | import qualified Data.Map as M 11 | import qualified Data.Text as T 12 | import qualified Data.Text.Prettyprint.Doc as D 13 | import qualified Data.Text.Prettyprint.Doc.Render.Text as D 14 | import qualified Data.Text.IO as IO 15 | import Data.Traversable (for) 16 | import qualified Language.PureScript.CST as CST 17 | import qualified Language.PureScript.Errors as Errs 18 | import qualified Language.PureScript.Make as Make 19 | import qualified Language.PureScript.Names as Names 20 | import qualified Language.PureScript.Optimizer.CoreAnf as O 21 | import qualified Language.PureScript.Optimizer.Types as O 22 | import qualified Language.PureScript.Optimizer as O 23 | import Language.PureScript.Options (defaultOptions) 24 | import System.Environment (getArgs) 25 | import System.Exit (die, exitFailure) 26 | import System.FilePath.Glob (glob) 27 | import System.IO 28 | 29 | actions :: MVar (M.Map Names.ModuleName O.OptimizerResult) -> Make.MakeActions Make.Make 30 | actions var = Make.MakeActions 31 | { getInputTimestamp = const (pure (Left Make.RebuildAlways)) 32 | , getOutputTimestamp = const (pure Nothing) 33 | , readExterns = error "readExterns not implemented" 34 | , codegen = \m _ _ -> lift . liftIO $ do 35 | env <- takeMVar var 36 | let 37 | res = O.optimize env m 38 | env' = M.insert (O.modName . O.optModule $ res) res env 39 | doc = D.renderStrict . D.layoutPretty (D.LayoutOptions D.Unbounded) . O.ppModule . O.optModule $ res 40 | path = "./output/" <> T.unpack (Names.runModuleName . O.modName . O.optModule $ res) 41 | IO.writeFile path doc 42 | putMVar var env' 43 | , ffiCodegen = \_ -> pure () 44 | , progress = \_ -> pure () 45 | } 46 | 47 | main :: IO () 48 | main = do 49 | hSetBuffering stdout LineBuffering 50 | args <- getArgs 51 | filePaths <- case filter ((/= '-') . head) args of 52 | [] -> die "File glob required." 53 | gs -> 54 | fmap join $ for gs $ \g -> do 55 | paths <- glob g 56 | when (null paths) $ die "Glob did not match any files." 57 | pure paths 58 | 59 | mbModules <- forConcurrently filePaths $ \path -> do 60 | src <- IO.readFile path 61 | pure . (path, src,) $ CST.parseModuleFromFile path src 62 | 63 | let 64 | modules = foldl' go id mbModules $ Right [] 65 | go k = \case 66 | (path, src, Left errs) -> do 67 | let errs' = (path, src,) <$> errs 68 | \case 69 | Left errs'' -> k $ Left (errs' <> errs'') 70 | Right _ -> k $ Left errs' 71 | (_, _, Right md) -> 72 | \case 73 | Left errs'' -> k $ Left errs'' 74 | Right mds -> k $ Right (md : mds) 75 | 76 | case modules of 77 | Left errs -> 78 | for_ errs $ \(path, _, err) -> 79 | putStrLn $ ex <> " " <> path <> " " <> CST.prettyPrintError err 80 | Right ms -> do 81 | var <- newMVar mempty 82 | res <- Make.runMake defaultOptions $ Make.make (actions var) ms 83 | case res of 84 | (Left errs, _) -> do 85 | hPutStrLn stderr (Errs.prettyPrintMultipleErrors Errs.defaultPPEOptions errs) 86 | exitFailure 87 | (Right _, _) -> do 88 | putStrLn $ check <> " OK" 89 | 90 | check :: String 91 | check = "\x1b[32m✓\x1b[0m" 92 | 93 | ex :: String 94 | ex = "\x1b[31m✗\x1b[0m" 95 | -------------------------------------------------------------------------------- /purescript-optimizer.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 22d959332a55b8d487dc2863b63b3499b2a8578e0f07d6a4e1c4bdca75d4d247 8 | 9 | name: purescript-optimizer 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/natefaubion/purescript-optimizer#readme 13 | bug-reports: https://github.com/natefaubion/purescript-optimizer/issues 14 | author: Nathan Faubion 15 | copyright: 2019 Nathan Faubion 16 | license: BSD3 17 | license-file: LICENSE 18 | build-type: Simple 19 | extra-source-files: 20 | README.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/natefaubion/purescript-optimizer 25 | 26 | library 27 | exposed-modules: 28 | Language.PureScript.Optimizer 29 | Language.PureScript.Optimizer.CoreAnf 30 | Language.PureScript.Optimizer.Rename 31 | Language.PureScript.Optimizer.Simplify 32 | Language.PureScript.Optimizer.Types 33 | other-modules: 34 | Paths_purescript_optimizer 35 | hs-source-dirs: 36 | src 37 | default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns 38 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-methods -Wredundant-constraints 39 | build-depends: 40 | Glob 41 | , async 42 | , base 43 | , containers 44 | , dlist 45 | , hashable 46 | , microlens 47 | , mtl 48 | , prettyprinter 49 | , purescript 50 | , text 51 | , transformers 52 | , unordered-containers 53 | default-language: Haskell2010 54 | 55 | executable purescript-optimizer-exe 56 | main-is: Main.hs 57 | other-modules: 58 | Paths_purescript_optimizer 59 | hs-source-dirs: 60 | app 61 | default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns 62 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-methods -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 63 | build-depends: 64 | Glob 65 | , async 66 | , base 67 | , containers 68 | , dlist 69 | , hashable 70 | , microlens 71 | , mtl 72 | , prettyprinter 73 | , purescript 74 | , purescript-optimizer 75 | , text 76 | , transformers 77 | , unordered-containers 78 | default-language: Haskell2010 79 | 80 | test-suite purescript-optimizer-test 81 | type: exitcode-stdio-1.0 82 | main-is: Main.hs 83 | other-modules: 84 | Paths_purescript_optimizer 85 | hs-source-dirs: 86 | test 87 | default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns 88 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-methods -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 89 | build-depends: 90 | Glob 91 | , async 92 | , base 93 | , containers 94 | , dlist 95 | , hashable 96 | , microlens 97 | , mtl 98 | , prettyprinter 99 | , purescript 100 | , purescript-optimizer 101 | , text 102 | , transformers 103 | , unordered-containers 104 | default-language: Haskell2010 105 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/CoreAnf.hs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.CoreAnf where 2 | 3 | import Prelude 4 | 5 | import Data.Coerce (coerce) 6 | import qualified Data.Hashable as H 7 | import qualified Data.Map as M 8 | import Data.Maybe (mapMaybe) 9 | import Data.Text (Text) 10 | import qualified Data.Text.Prettyprint.Doc as D 11 | import GHC.Generics (Generic) 12 | import qualified Language.PureScript.AST.Literals as L 13 | import qualified Language.PureScript.Names as N 14 | import Language.PureScript.PSString (PSString) 15 | 16 | data Name = Name 17 | { nameQual :: [Text] 18 | , nameUnique :: Int 19 | } deriving (Show, Eq, Ord, Generic) 20 | 21 | instance H.Hashable Name 22 | 23 | data Module a = Module 24 | { modName :: N.ModuleName 25 | , modDeps :: [N.ModuleName] 26 | , modDecls :: M.Map N.Ident (Name, Decl a) 27 | , modSort :: [N.Ident] 28 | } deriving (Show, Functor) 29 | 30 | data Decl a 31 | = DeclCtor Int 32 | | DeclExpr [Name] (Expr a) 33 | | DeclForeign N.Ident 34 | deriving (Show, Functor) 35 | 36 | data Expr a 37 | = Lit a (L.Literal Name) 38 | | Let a [Binding a] (Expr a) 39 | | Abs a [Name] (Expr a) 40 | | App a Name [Name] 41 | | Var a Name 42 | | Access a Name PSString 43 | | Update a Name [(PSString, Name)] 44 | | Case a [Name] [CaseAlternative a] 45 | deriving (Show, Functor) 46 | 47 | data Binding a 48 | = NonRec a Name (Expr a) 49 | | Rec [((a, Name), Expr a)] 50 | deriving (Show, Functor) 51 | 52 | data CaseAlternative a = CaseAlternative 53 | { caltBinders :: [Binder a] 54 | , caltResult :: Guarded a 55 | } deriving (Show, Functor) 56 | 57 | data Guarded a 58 | = Unguarded (Expr a) 59 | | Guarded [(Expr a, Expr a)] 60 | deriving (Show, Functor) 61 | 62 | data Binder a 63 | = BinderWildcard a 64 | | BinderLit a (L.Literal (Binder a)) 65 | | BinderVar a Name 66 | | BinderNamed a Name (Binder a) 67 | | BinderCtor a Name [Binder a] 68 | deriving (Show, Functor) 69 | 70 | exprAnn :: Functor f => (a -> f a) -> Expr a -> f (Expr a) 71 | exprAnn k = \case 72 | Lit a b -> (\z -> Lit z b) <$> k a 73 | Let a b c -> (\z -> Let z b c) <$> k a 74 | Abs a b c -> (\z -> Abs z b c) <$> k a 75 | App a b c -> (\z -> App z b c) <$> k a 76 | Var a b -> (\z -> Var z b) <$> k a 77 | Access a b c -> (\z -> Access z b c) <$> k a 78 | Update a b c -> (\z -> Update z b c) <$> k a 79 | Case a b c -> (\z -> Case z b c) <$> k a 80 | 81 | ppModule :: Module a -> D.Doc void 82 | ppModule (Module {..}) = 83 | D.vsep $ 84 | [ "module" D.<+> D.pretty (N.runModuleName modName) 85 | , "import" 86 | , D.indent 2 87 | . D.vsep 88 | . fmap (D.pretty . N.runModuleName) 89 | $ modDeps 90 | , "export" 91 | , D.indent 2 92 | . D.vsep 93 | . fmap (ppExport . fmap fst) 94 | . M.toList 95 | $ modDecls 96 | ] <> decls 97 | where 98 | decls = 99 | fmap (uncurry (ppDecl modName)) 100 | . mapMaybe (flip M.lookup modDecls) 101 | $ modSort 102 | 103 | ppExport (ident, n) = 104 | D.pretty (N.runIdent ident) 105 | <> " " 106 | <> ppName modName n 107 | 108 | ppDecl :: N.ModuleName -> Name -> Decl a -> D.Doc void 109 | ppDecl mn n = \case 110 | DeclCtor len -> 111 | D.hsep 112 | [ ppName mn n 113 | , "=" 114 | , "constructor" 115 | , D.pretty len 116 | ] 117 | DeclForeign ident -> 118 | D.hsep 119 | [ ppName mn n 120 | , "=" 121 | , "foreign" 122 | , D.pretty $ show $ N.runIdent ident 123 | ] 124 | DeclExpr group expr -> 125 | D.vsep 126 | [ ppName mn n <> ppRec group D.<+> "=" 127 | , D.indent 2 128 | . ppExpr mn 129 | $ expr 130 | ] 131 | 132 | ppExpr :: N.ModuleName -> Expr a -> D.Doc void 133 | ppExpr mn = \case 134 | Lit _ x -> 135 | ppLit 136 | . fmap (ppName mn) 137 | $ x 138 | Let _ bs expr -> do 139 | D.vsep 140 | [ D.vsep 141 | . fmap (ppBinding mn) 142 | $ bs 143 | , ppExpr mn expr 144 | ] 145 | Abs _ as b -> 146 | D.vsep 147 | [ "\\" <> D.hsep (ppName mn <$> as) D.<+> "->" 148 | , D.indent 2 149 | . ppExpr mn 150 | $ b 151 | ] 152 | App _ a bs -> 153 | D.lparen 154 | <> D.hsep (ppName mn a : (ppName mn <$> bs)) 155 | <> D.rparen 156 | Var _ n -> 157 | ppName mn n 158 | Access _ a b -> 159 | ppName mn a <> "." <> D.pretty (show b) 160 | Update _ a pairs -> 161 | ppName mn a <> "." <> do 162 | D.encloseSep D.lbrace D.rbrace D.comma 163 | . fmap (\(k, v) -> D.pretty (show k) D.<+> D.equals D.<+> ppName mn v) 164 | $ pairs 165 | Case _ ns alts -> do 166 | D.vsep 167 | [ "case" D.<+> D.hsep (ppName mn <$> ns) D.<+> "of" 168 | , D.indent 2 169 | . D.vsep 170 | . fmap (ppCaseAlternative mn) 171 | $ alts 172 | ] 173 | 174 | ppBinding :: N.ModuleName -> Binding a -> D.Doc void 175 | ppBinding mn = \case 176 | NonRec _ n a -> 177 | D.vsep 178 | [ ppName mn n D.<+> "=" 179 | , D.indent 2 180 | . ppExpr mn 181 | $ a 182 | ] 183 | Rec bs -> do 184 | let 185 | group = snd . fst <$> bs 186 | ppFn ((_, n), expr) = 187 | D.vsep 188 | [ ppName mn n <> ppRec group D.<+> "=" 189 | , D.indent 2 190 | . ppExpr mn 191 | $ expr 192 | ] 193 | D.vsep 194 | . fmap ppFn 195 | $ bs 196 | 197 | ppCaseAlternative :: N.ModuleName -> CaseAlternative a -> D.Doc void 198 | ppCaseAlternative mn (CaseAlternative bs res) = 199 | case res of 200 | Guarded gs -> 201 | D.vsep 202 | [ bs' 203 | , D.indent 2 204 | . D.vsep 205 | . fmap ppGuard 206 | $ gs 207 | ] 208 | Unguarded expr -> 209 | D.vsep 210 | [ bs' D.<+> "->" 211 | , D.indent 2 212 | . ppExpr mn 213 | $ expr 214 | ] 215 | where 216 | bs' = 217 | D.hsep 218 | . fmap (ppBinder mn) 219 | $ bs 220 | 221 | ppGuard (a, b) = 222 | D.vsep 223 | [ "|" D.<+> D.align (ppExpr mn a) D.<+> "->" 224 | , D.indent 4 225 | . ppExpr mn 226 | $ b 227 | ] 228 | 229 | ppBinder :: N.ModuleName -> Binder a -> D.Doc void 230 | ppBinder mn = \case 231 | BinderWildcard _ -> 232 | "_" 233 | BinderLit _ x -> 234 | ppLit 235 | . fmap (ppBinder mn) 236 | $ x 237 | BinderVar _ x -> 238 | ppName mn x 239 | BinderNamed _ a b -> 240 | D.lparen 241 | <> ppName mn a 242 | D.<+> "=" 243 | D.<+> ppBinder mn b 244 | <> D.rparen 245 | BinderCtor _ a bs -> 246 | D.lparen 247 | <> D.hsep (ppName mn a : (ppBinder mn <$> bs)) 248 | <> D.rparen 249 | 250 | ppLit :: L.Literal (D.Doc void) -> D.Doc void 251 | ppLit = \case 252 | L.ArrayLiteral x -> 253 | D.encloseSep D.lbracket D.rbracket D.comma x 254 | L.ObjectLiteral pairs -> 255 | D.encloseSep D.lbrace D.rbrace D.comma 256 | . fmap (\(k, v) -> D.pretty (show k) D.<+> D.equals D.<+> v) 257 | $ pairs 258 | L.NumericLiteral x -> 259 | either D.pretty D.pretty x 260 | L.StringLiteral x -> 261 | D.pretty $ show x 262 | L.CharLiteral x -> 263 | D.pretty $ show x 264 | L.BooleanLiteral x -> 265 | if x then "true" else "false" 266 | 267 | ppName :: N.ModuleName -> Name -> D.Doc void 268 | ppName mn (Name mn' n) 269 | | mn == coerce mn' = "@" <> D.pretty n 270 | | otherwise = D.pretty (N.runModuleName (coerce mn')) <> "@" <> D.pretty n 271 | 272 | ppRec :: [Name] -> D.Doc void 273 | ppRec group 274 | | [] <- group = mempty 275 | | otherwise = 276 | D.lbracket 277 | <> D.hsep (D.punctuate D.comma (("@" <>) . D.pretty . nameUnique <$> group)) 278 | <> D.rbracket 279 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/Rename.hs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.Rename where 2 | 3 | import Prelude 4 | 5 | import Control.Monad (join) 6 | import qualified Control.Monad.State.Class as MS 7 | import qualified Control.Monad.Trans.State.Strict as S 8 | import Data.Coerce (coerce) 9 | import Data.Foldable (fold, toList) 10 | import Lens.Micro ((^.), _3) 11 | import qualified Data.Map.Strict as M 12 | import Data.Maybe (catMaybes) 13 | import Data.Text (Text) 14 | import qualified Language.PureScript.AST.SourcePos as Pos 15 | import qualified Language.PureScript.CoreFn as C 16 | import qualified Language.PureScript.Names as N 17 | import Language.PureScript.Optimizer.CoreAnf 18 | import Language.PureScript.Optimizer.Types 19 | 20 | type Scope = M.Map (N.Qualified N.Ident) Name 21 | 22 | data RenameState = RenameState 23 | { rsModuleName :: N.ModuleName 24 | , rsFresh :: Int 25 | , rsScope :: Scope 26 | } 27 | 28 | freshName :: MS.MonadState RenameState m => m Name 29 | freshName = MS.state $ \st@(RenameState {..}) -> 30 | (Name (coerce rsModuleName) rsFresh, st { rsFresh = rsFresh + 1 }) 31 | 32 | bindName :: MS.MonadState RenameState m => N.Qualified N.Ident -> m Name 33 | bindName ident = MS.state $ \st@(RenameState {..}) -> do 34 | let 35 | name = Name (getQual (coerce rsModuleName) ident) rsFresh 36 | scope = 37 | case N.getQual ident of 38 | Nothing -> 39 | M.insert ident name 40 | . M.insert (N.Qualified (Just rsModuleName) . N.disqualify $ ident) name 41 | $ rsScope 42 | Just _ -> 43 | M.insert ident name rsScope 44 | (name, st { rsFresh = rsFresh + 1, rsScope = scope }) 45 | 46 | bindName' :: MS.MonadState RenameState m => N.Ident -> m Name 47 | bindName' = bindName . N.Qualified Nothing 48 | 49 | assocName :: MS.MonadState RenameState m => N.Qualified N.Ident -> Name -> m () 50 | assocName ident name = MS.state $ \st@(RenameState {..}) -> do 51 | let 52 | scope = 53 | case N.getQual ident of 54 | Nothing -> 55 | M.insert ident name 56 | . M.insert (N.Qualified (Just rsModuleName) . N.disqualify $ ident) name 57 | $ rsScope 58 | Just _ -> 59 | M.insert ident name rsScope 60 | ((), st { rsScope = scope }) 61 | 62 | assocName' :: MS.MonadState RenameState m => N.Ident -> Name -> m () 63 | assocName' = assocName . N.Qualified Nothing 64 | 65 | getName :: MS.MonadState RenameState m => N.Qualified N.Ident -> m Name 66 | getName ident = do 67 | RenameState { rsModuleName, rsScope } <- MS.get 68 | pure $ case M.lookup ident rsScope of 69 | Nothing -> 70 | error 71 | (unlines 72 | $ "getName: unknown free variable " <> show ident 73 | : show rsModuleName 74 | : fmap show (M.toList rsScope)) 75 | -- (fromMaybe rsModuleName . N.getQual $ ident, -1) 76 | Just n -> n 77 | 78 | currentModule :: MS.MonadState RenameState m => m N.ModuleName 79 | currentModule = do 80 | RenameState { rsModuleName } <- MS.get 81 | pure rsModuleName 82 | 83 | scoped :: MS.MonadState RenameState m => m a -> m a 84 | scoped m = do 85 | RenameState { rsScope } <- MS.get 86 | res <- m 87 | MS.modify (\st -> st { rsScope = rsScope }) 88 | pure $ res 89 | 90 | renameModule :: M.Map N.ModuleName (Module OptimizerAnn) -> C.Module C.Ann -> Module OptimizerAnn 91 | renameModule env (C.Module {..}) = flip S.evalState state $ do 92 | frn <- traverse goForeign moduleForeign 93 | decls <- join <$> traverse goBind moduleDecls 94 | pure $ Module 95 | { modName = moduleName 96 | , modDeps = snd <$> moduleImports 97 | , modDecls = M.fromList frn <> M.fromList decls 98 | , modSort = fmap fst frn <> fmap fst decls 99 | } 100 | where 101 | state = 102 | RenameState moduleName 0 (scope <> M.singleton identUndefined (Name (coerce prim) 0)) 103 | 104 | scope = 105 | fold 106 | . catMaybes 107 | . fmap (fmap scopeFn . flip M.lookup env . snd) 108 | $ moduleImports 109 | 110 | nameFn mn (k, v) = 111 | (N.Qualified (Just mn) k, fst v) 112 | 113 | scopeFn (Module {..}) = 114 | M.fromList 115 | . fmap (nameFn modName) 116 | . M.toList 117 | $ modDecls 118 | 119 | goForeign ident = do 120 | n <- bindName' ident 121 | pure (ident, (n, DeclForeign ident)) 122 | 123 | goBind = \case 124 | C.NonRec _ ident decl -> do 125 | n <- bindName' ident 126 | pure . (ident,) . (n,) <$> goDecl [] decl 127 | C.Rec bs -> do 128 | bs' <- traverse (\((_, ident), expr) -> (ident,) . (,expr) <$> bindName' ident) bs 129 | traverse (traverse (traverse (goDecl (fst . snd <$> bs')))) bs' 130 | 131 | goDecl group = \case 132 | C.Constructor _ _ _ fields -> 133 | pure . DeclCtor . length $ fields 134 | expr -> scoped $ do 135 | DeclExpr group <$> renameExpr expr 136 | 137 | renameExpr :: MS.MonadState RenameState m => C.Expr C.Ann -> m (Expr OptimizerAnn) 138 | renameExpr = goExpr 139 | where 140 | goExpr = scoped . \case 141 | C.Literal ann a -> do 142 | goLit (optAnn ann) a 143 | C.Accessor ann p expr -> scoped $ do 144 | expr' <- goLetExpr expr 145 | pure $ buildLet [expr'] $ Access (optAnn ann) (letName expr') p 146 | C.ObjectUpdate ann expr pairs -> do 147 | expr' <- goLetExpr expr 148 | pairs' <- traverse (traverse goLetExpr) pairs 149 | pure 150 | . buildLet (expr' : fmap snd pairs') 151 | . Update (optAnn ann) (letName expr') 152 | . fmap (fmap letName) 153 | $ pairs' 154 | C.Abs ann n expr -> do 155 | n' <- bindName' n 156 | Abs (optAnn ann) [n'] <$> goExpr expr 157 | C.App ann a b -> do 158 | a' <- goLetExpr a 159 | b' <- goLetExpr b 160 | pure 161 | . buildLet [a', b'] 162 | $ App (optAnn ann) (letName a') [letName b'] 163 | C.Let ann bs expr -> do 164 | bs' <- catMaybes <$> traverse goBind bs 165 | expr' <- goExpr expr 166 | pure $ Let (optAnn ann) bs' expr' 167 | C.Case ann exprs alts -> do 168 | exprs' <- traverse goLetExpr exprs 169 | alts' <- traverse goAlt alts 170 | pure 171 | . buildLet exprs' 172 | . flip (Case (optAnn ann)) alts' 173 | . fmap letName 174 | $ exprs' 175 | C.Var ann v -> 176 | Var (optAnn ann) <$> getName v 177 | C.Constructor _ _ ident _ -> 178 | error $ "renameExpr: Invalid constructor " <> show ident 179 | 180 | goLit ann = \case 181 | C.ArrayLiteral exprs -> scoped $ do 182 | exprs' <- traverse goLetExpr exprs 183 | pure 184 | . buildLet exprs' 185 | . Lit ann 186 | . C.ArrayLiteral 187 | . fmap letName 188 | $ exprs' 189 | C.ObjectLiteral pairs -> scoped $ do 190 | pairs' <- traverse (traverse goLetExpr) pairs 191 | pure 192 | . buildLet (fmap snd pairs') 193 | . Lit ann 194 | . C.ObjectLiteral 195 | . fmap (fmap letName) 196 | $ pairs' 197 | C.NumericLiteral x -> 198 | pure . Lit ann . C.NumericLiteral $ x 199 | C.StringLiteral x -> 200 | pure . Lit ann . C.StringLiteral $ x 201 | C.CharLiteral x -> 202 | pure . Lit ann . C.CharLiteral $ x 203 | C.BooleanLiteral x -> 204 | pure . Lit ann . C.BooleanLiteral $ x 205 | 206 | goBind = \case 207 | C.NonRec _ a (C.Var _ b) -> do 208 | n <- getName b 209 | assocName' a n 210 | pure $ Nothing 211 | C.NonRec ann ident expr -> do 212 | n <- bindName' ident 213 | expr' <- goExpr expr 214 | pure . Just $ NonRec (optAnn ann) n expr' 215 | C.Rec bs -> do 216 | let 217 | bindFn ((ann, ident), expr) = 218 | (,expr) . (optAnn ann,) <$> bindName' ident 219 | bs' <- traverse bindFn bs 220 | bs'' <- traverse (traverse goExpr) bs' 221 | pure . Just $ Rec bs'' 222 | 223 | goAlt (C.CaseAlternative bs res) = 224 | scoped $ CaseAlternative 225 | <$> traverse goBinder bs 226 | <*> goResult res 227 | 228 | goBinder = \case 229 | C.NullBinder ann -> 230 | pure $ BinderWildcard (optAnn ann) 231 | C.LiteralBinder ann lit -> 232 | BinderLit (optAnn ann) <$> goBinderLit lit 233 | C.VarBinder ann ident -> 234 | BinderVar (optAnn ann) <$> bindName' ident 235 | C.NamedBinder ann ident b -> 236 | BinderNamed (optAnn ann) <$> bindName' ident <*> goBinder b 237 | C.ConstructorBinder ann _ ctor args -> 238 | BinderCtor (optAnn ann) <$> getName (ctorToIdent <$> ctor) <*> traverse goBinder args 239 | 240 | goBinderLit = \case 241 | C.ArrayLiteral bs -> 242 | C.ArrayLiteral <$> traverse goBinder bs 243 | C.ObjectLiteral pairs -> 244 | C.ObjectLiteral <$> traverse (traverse goBinder) pairs 245 | C.NumericLiteral x -> 246 | pure $ C.NumericLiteral x 247 | C.StringLiteral x -> 248 | pure $ C.StringLiteral x 249 | C.CharLiteral x -> 250 | pure $ C.CharLiteral x 251 | C.BooleanLiteral x -> 252 | pure $ C.BooleanLiteral x 253 | 254 | goResult = \case 255 | Left gs -> 256 | Guarded <$> traverse (\(a, b) -> (,) <$> goExpr a <*> goExpr b) gs 257 | Right a -> 258 | Unguarded <$> goExpr a 259 | 260 | goLetExpr = \case 261 | C.Var _ a -> do 262 | Left <$> getName a 263 | expr -> do 264 | n <- freshName 265 | expr' <- goExpr expr 266 | pure $ Right (optAnn . C.extractAnn $ expr, n, expr') 267 | 268 | letName = \case 269 | Left n -> n 270 | Right (_, n, _) -> n 271 | 272 | buildLet bs expr = 273 | case bs >>= toList of 274 | [] -> expr 275 | b : bs' -> do 276 | let 277 | ann1 = b ^. _3 . exprAnn 278 | ann2 = expr ^. exprAnn 279 | ann = ann2 { annSpan = Pos.widenSourceSpan (annSpan ann1) (annSpan ann2) } 280 | bs'' = fmap (\(x, y, z) -> NonRec x y z) $ b : bs' 281 | Let ann bs'' expr 282 | 283 | ctorToIdent :: N.ProperName 'N.ConstructorName -> N.Ident 284 | ctorToIdent = N.Ident . N.runProperName 285 | 286 | getQual :: [Text] -> N.Qualified a -> [Text] 287 | getQual def = maybe def coerce . N.getQual 288 | 289 | prim :: N.ModuleName 290 | prim = N.ModuleName [N.ProperName "Prim"] 291 | 292 | identUndefined :: N.Qualified N.Ident 293 | identUndefined = N.Qualified (Just prim) (N.Ident "undefined") 294 | --------------------------------------------------------------------------------