diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # dickinson +## 1.3.0.1 + + * Make some stuff in the pattern match exhaustiveness checker strict for + better performance + * Use strict `State` monad in the scope checker for better performance + ## 1.3.0.0 * Linter now reports inexhaustive pattern matches diff --git a/language-dickinson.cabal b/language-dickinson.cabal --- a/language-dickinson.cabal +++ b/language-dickinson.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: language-dickinson -version: 1.3.0.0 +version: 1.3.0.1 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2020 Vanessa McHale diff --git a/lib/noun.dck b/lib/noun.dck --- a/lib/noun.dck +++ b/lib/noun.dck @@ -310,5 +310,6 @@ (| "apotheosis") (| "aphelion") (| "bevel") + (| "thurible") (| "perihelion") (| "folderol")))) diff --git a/src/Language/Dickinson/Check/Exhaustive.hs b/src/Language/Dickinson/Check/Exhaustive.hs --- a/src/Language/Dickinson/Check/Exhaustive.hs +++ b/src/Language/Dickinson/Check/Exhaustive.hs @@ -1,5 +1,4 @@ module Language.Dickinson.Check.Exhaustive ( checkExhaustive - , foliate ) where import Control.Applicative ((<|>)) diff --git a/src/Language/Dickinson/Check/Scope.hs b/src/Language/Dickinson/Check/Scope.hs --- a/src/Language/Dickinson/Check/Scope.hs +++ b/src/Language/Dickinson/Check/Scope.hs @@ -7,7 +7,7 @@ import Control.Applicative ((<|>)) import Control.Monad.Except (MonadError) -import Control.Monad.State (State, evalState, get, modify) +import Control.Monad.State.Strict (State, evalState, get, modify) import Data.Foldable (traverse_) import qualified Data.IntSet as IS import Language.Dickinson.Check.Common diff --git a/src/Language/Dickinson/Pattern.hs b/src/Language/Dickinson/Pattern.hs --- a/src/Language/Dickinson/Pattern.hs +++ b/src/Language/Dickinson/Pattern.hs @@ -17,6 +17,8 @@ matches (OrPattern _ ps) e = any (`matches` e) ps matches _ _ = False +-- | Given an expression, find the first pattern it matches, failing if it +-- matches nothing. matchPattern :: MonadError (DickinsonError a) m => a -> Expression a -> [(Pattern a, Expression a)] -> m (Pattern a, Expression a) matchPattern l e (p:ps) | matches (fst p) e = pure p | otherwise = matchPattern l e ps diff --git a/src/Language/Dickinson/Pattern/Useless.hs b/src/Language/Dickinson/Pattern/Useless.hs --- a/src/Language/Dickinson/Pattern/Useless.hs +++ b/src/Language/Dickinson/Pattern/Useless.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} --- | This module is loosely based off _Warnings for pattern matching_ by Luc +-- | This module is loosely based off /Warnings for pattern matching/ by Luc -- Maranget module Language.Dickinson.Pattern.Useless ( PatternM , runPatternM @@ -12,20 +12,20 @@ , specializeTag ) where -import Control.Monad (forM, forM_) -import Control.Monad.State (State, evalState, get) -import Data.Coerce (coerce) -import Data.Foldable (toList, traverse_) -import Data.Functor (void) -import Data.IntMap (findWithDefault) -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS +import Control.Monad (forM, forM_) +import Control.Monad.State.Strict (State, evalState, get) +import Data.Coerce (coerce) +import Data.Foldable (toList, traverse_) +import Data.Functor (void) +import Data.IntMap.Strict (findWithDefault) +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS import Data.List.Ext import Language.Dickinson.Name import Language.Dickinson.Type import Language.Dickinson.Unique -import Lens.Micro (Lens') -import Lens.Micro.Mtl (modifying) +import Lens.Micro (Lens') +import Lens.Micro.Mtl (modifying) -- all constructors of a data PatternEnv = PatternEnv { allCons :: IM.IntMap IS.IntSet -- ^ all constructors indexed by type @@ -49,6 +49,7 @@ patternEnvDecls :: [Declaration a] -> PatternM () patternEnvDecls = traverse_ declAdd +-- TODO: just reader monad... writer at beginning? type PatternM = State PatternEnv runPatternM :: PatternM a -> a @@ -81,7 +82,7 @@ sanityFailed = error "Sanity check failed! Perhaps you ran the pattern match exhaustiveness checker on an ill-typed program?" specializeTag :: Name a -> [[Pattern a]] -> [[Pattern a]] -specializeTag c = {-# SCC "specializeTag" #-} concatMap withRow +specializeTag c = concatMap withRow where withRow (PatternCons _ c':ps) | c' == c = [ps] | otherwise = [] withRow (PatternTuple{}:_) = sanityFailed @@ -91,7 +92,7 @@ withRow [] = emptySpecialize specializeTuple :: Int -> [[Pattern a]] -> [[Pattern a]] -specializeTuple n = {-# SCC "specializeTuple" #-} concatMap withRow +specializeTuple n = concatMap withRow where withRow (PatternTuple _ ps:ps') = [toList ps ++ ps'] withRow (p@Wildcard{}:ps') = [replicate n p ++ ps'] withRow (p@PatternVar{}:ps') = [replicate n p ++ ps'] @@ -104,7 +105,7 @@ -- | \\( \matcal(D) \\) in the Maranget paper defaultMatrix :: [[Pattern a]] -> [[Pattern a]] -defaultMatrix = {-# SCC "defaultMatrix" #-} concatMap withRow where +defaultMatrix = concatMap withRow where withRow [] = error "Internal error: tried to take default matrix of an empty row" withRow (PatternTuple{}:_) = error "Sanity check failed!" -- because a tuple would be complete by itself withRow (PatternCons{}:_) = [] @@ -144,13 +145,7 @@ usefulMaranget ps (PatternCons _ c:qs) = usefulMaranget (specializeTag c ps) qs usefulMaranget ps (PatternTuple _ ps':qs) = usefulMaranget (specializeTuple (length ps') ps) (toList ps' ++ qs) usefulMaranget ps (OrPattern _ ps':qs) = forAnyA ps' $ \p -> usefulMaranget ps (p:qs) -usefulMaranget ps (q@Wildcard{}:qs) = do - cont <- fstComplete ps - case cont of - NotComplete -> usefulMaranget (defaultMatrix ps) qs - CompleteTuple n -> usefulMaranget (specializeTuple n ps) (specializeTupleVector n q qs) - CompleteTags ns -> or <$> (forM ns $ \n -> usefulMaranget (specializeTag n (forget ps)) (fmap void qs)) -usefulMaranget ps (q@PatternVar{}:qs) = do +usefulMaranget ps (q:qs) = do -- pattern var or wildcard cont <- fstComplete ps case cont of NotComplete -> usefulMaranget (defaultMatrix ps) qs