language-dickinson 1.4.1.1 → 1.4.1.2
raw patch · 6 files changed
+80/−81 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- README.md +0/−1
- language-dickinson.cabal +1/−1
- lib/noun.dck +2/−0
- src/Language/Dickinson/Check/Exhaustive.hs +39/−43
- src/Language/Dickinson/Pattern/Useless.hs +34/−36
CHANGELOG.md view
@@ -1,5 +1,9 @@ # dickinson +## 1.4.1.2++ * Performance improvements in the pattern match exhaustiveness checker+ ## 1.4.1.1 * Bundle `user-guide.pdf` in tarball
README.md view
@@ -21,7 +21,6 @@ computer: ```bash- curl -sSl https://raw.githubusercontent.com/vmchale/dickinson/master/bash/install.sh | sh -s ```
language-dickinson.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: language-dickinson-version: 1.4.1.1+version: 1.4.1.2 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2020 Vanessa McHale
lib/noun.dck view
@@ -61,7 +61,9 @@ (| "autonomous") (| "pseudonym") (| "perfidy")+ (| "potboiler") (| "heliophagy")+ (| "poultice") (| "aril") (| "valedictorian") (| "cathexis")
src/Language/Dickinson/Check/Exhaustive.hs view
@@ -3,9 +3,9 @@ import Control.Applicative ((<|>)) import Data.Foldable (toList)+import Data.Foldable.Ext import Data.List (inits) import Data.Maybe (mapMaybe)-import Language.Dickinson.Check.Common import Language.Dickinson.Error import Language.Dickinson.Pattern.Useless import Language.Dickinson.Type@@ -13,28 +13,26 @@ -- | Check that there are no useless pattern clauses and check that the pattern -- matches are exhaustive checkExhaustive :: [Declaration a] -> Maybe (DickinsonWarning a)-checkExhaustive ds = runPatternM (checkDeclsM ds)+checkExhaustive = checkDeclsM -checkDeclsM :: [Declaration a] -> PatternM (Maybe (DickinsonWarning a))+checkDeclsM :: [Declaration a] -> Maybe (DickinsonWarning a) checkDeclsM ds =- patternEnvDecls ds *>- mapSumM checkDeclM ds+ let pEnv = runPatternM $ patternEnvDecls ds in+ foldMapAlternative (checkDecl pEnv) ds -checkDeclM :: Declaration a -> PatternM (Maybe (DickinsonWarning a))-checkDeclM TyDecl{} = pure Nothing-checkDeclM (Define _ _ e) = checkExprM e+checkDecl :: PatternEnv -> Declaration a -> Maybe (DickinsonWarning a)+checkDecl _ TyDecl{} = Nothing+checkDecl env (Define _ _ e) = checkExpr env e -isExhaustiveM :: [Pattern a] -> a -> PatternM (Maybe (DickinsonWarning a))-isExhaustiveM ps loc = do- e <- isExhaustive ps- pure $ if e+isExhaustiveErr :: PatternEnv -> [Pattern a] -> a -> Maybe (DickinsonWarning a)+isExhaustiveErr env ps loc =+ if isExhaustive env ps then Nothing else Just $ InexhaustiveMatch loc -uselessErr :: [Pattern a] -> Pattern a -> PatternM (Maybe (DickinsonWarning a))-uselessErr ps p = {-# SCC "uselessErr" #-} do- e <- useful ps p- pure $ if e+uselessErr :: PatternEnv -> [Pattern a] -> Pattern a -> Maybe (DickinsonWarning a)+uselessErr env ps p = {-# SCC "uselessErr" #-}+ if useful env ps p then Nothing else Just $ UselessPattern (patAnn p) p @@ -44,31 +42,29 @@ split [_] = Nothing split xs = Just (init xs, last xs) -checkMatch :: [Pattern a] -> a -> PatternM (Maybe (DickinsonWarning a))-checkMatch ps loc = {-# SCC "checkMatch" #-}- (<|>)- <$> mapSumM (uncurry uselessErr) ({-# SCC "foliate" #-} foliate ps)- <*> isExhaustiveM ps loc+checkMatch :: PatternEnv -> [Pattern a] -> a -> Maybe (DickinsonWarning a)+checkMatch env ps loc = {-# SCC "checkMatch" #-}+ foldMapAlternative (uncurry (uselessErr env)) ({-# SCC "foliate" #-} foliate ps)+ <|> isExhaustiveErr env ps loc -checkExprM :: Expression a -> PatternM (Maybe (DickinsonWarning a))-checkExprM Var{} = pure Nothing-checkExprM Literal{} = pure Nothing-checkExprM StrChunk{} = pure Nothing-checkExprM Constructor{} = pure Nothing-checkExprM BuiltinFn{} = pure Nothing-checkExprM Random{} = pure Nothing-checkExprM (Flatten _ e) = checkExprM e-checkExprM (Annot _ e _) = checkExprM e-checkExprM (Lambda _ _ _ e) = checkExprM e-checkExprM (Choice _ brs) = mapSumM checkExprM (snd <$> brs)-checkExprM (Let _ brs e) = (<|>) <$> mapSumM checkExprM (snd <$> brs) <*> checkExprM e-checkExprM (Bind _ brs e) = (<|>) <$> mapSumM checkExprM (snd <$> brs) <*> checkExprM e-checkExprM (Interp _ es) = mapSumM checkExprM es-checkExprM (MultiInterp _ es) = mapSumM checkExprM es-checkExprM (Apply _ e e') = (<|>) <$> checkExprM e <*> checkExprM e'-checkExprM (Concat _ es) = mapSumM checkExprM es-checkExprM (Tuple _ es) = mapSumM checkExprM es-checkExprM (Match l e brs) =- (<|>)- <$> checkExprM e- <*> ((<|>) <$> checkMatch (toList (fst <$> brs)) l <*> mapSumM checkExprM (snd <$> brs))+checkExpr :: PatternEnv -> Expression a -> Maybe (DickinsonWarning a)+checkExpr _ Var{} = Nothing+checkExpr _ Literal{} = Nothing+checkExpr _ StrChunk{} = Nothing+checkExpr _ Constructor{} = Nothing+checkExpr _ BuiltinFn{} = Nothing+checkExpr _ Random{} = Nothing+checkExpr env (Flatten _ e) = checkExpr env e+checkExpr env (Annot _ e _) = checkExpr env e+checkExpr env (Lambda _ _ _ e) = checkExpr env e+checkExpr env (Choice _ brs) = foldMapAlternative (checkExpr env) (snd <$> brs)+checkExpr env (Let _ brs e) = foldMapAlternative (checkExpr env) (snd <$> brs) <|> checkExpr env e+checkExpr env (Bind _ brs e) = foldMapAlternative (checkExpr env) (snd <$> brs) <|> checkExpr env e+checkExpr env (Interp _ es) = foldMapAlternative (checkExpr env) es+checkExpr env (MultiInterp _ es) = foldMapAlternative (checkExpr env) es+checkExpr env (Apply _ e e') = checkExpr env e <|> checkExpr env e'+checkExpr env (Concat _ es) = foldMapAlternative (checkExpr env) es+checkExpr env (Tuple _ es) = foldMapAlternative (checkExpr env) es+checkExpr env (Match l e brs) =+ checkExpr env e+ <|> checkMatch env (toList (fst <$> brs)) l <|> foldMapAlternative (checkExpr env) (snd <$> brs)
src/Language/Dickinson/Pattern/Useless.hs view
@@ -3,6 +3,7 @@ -- | This module is loosely based off /Warnings for pattern matching/ by Luc -- Maranget module Language.Dickinson.Pattern.Useless ( PatternM+ , PatternEnv , runPatternM , isExhaustive , patternEnvDecls@@ -12,15 +13,14 @@ , specializeTag ) where -import Control.Monad (forM, forM_)-import Control.Monad.State.Strict (State, evalState, get)+import Control.Monad (forM_)+import Control.Monad.State.Strict (State, execState) 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@@ -52,34 +52,32 @@ -- TODO: just reader monad... writer at beginning? type PatternM = State PatternEnv -runPatternM :: PatternM a -> a-runPatternM = flip evalState (PatternEnv mempty mempty)+runPatternM :: PatternM a -> PatternEnv+runPatternM = flip execState (PatternEnv mempty mempty) -- given a constructor name, get the IntSet of all constructors of that type-assocUniques :: Name a -> PatternM IS.IntSet-assocUniques (Name _ (Unique i) _) = {-# SCC "assocUniques" #-} do- st <- get- let ty = findWithDefault internalError i (types st)- pure $ findWithDefault internalError ty (allCons st)+assocUniques :: PatternEnv -> Name a -> IS.IntSet+assocUniques env (Name _ (Unique i) _) = {-# SCC "assocUniques" #-}+ let ty = findWithDefault internalError i (types env)+ in findWithDefault internalError ty (allCons env) internalError :: a internalError = error "Internal error: lookup in a PatternEnv failed" -isExhaustive :: [Pattern a] -> PatternM Bool-isExhaustive ps = {-# SCC "isExhaustive" #-} not <$> useful ps (Wildcard undefined)+isExhaustive :: PatternEnv -> [Pattern a] -> Bool+isExhaustive env ps = {-# SCC "isExhaustive" #-} not $ useful env ps (Wildcard undefined) -isCompleteSet :: [Name a] -> PatternM (Maybe [Name ()])-isCompleteSet [] = pure Nothing-isCompleteSet ns@(n:_) = do- allU <- assocUniques n- let ty = coerce (unique <$> ns)- pure $- if IS.null (allU IS.\\ IS.fromList ty)+isCompleteSet :: PatternEnv -> [Name a] -> Maybe [Name ()]+isCompleteSet _ [] = Nothing+isCompleteSet env ns@(n:_) =+ let allU = assocUniques env n+ ty = coerce (unique <$> ns)+ in if IS.null (allU IS.\\ IS.fromList ty) then Just ((\u -> Name undefined (Unique u) ()) <$> IS.toList allU) else Nothing -useful :: [Pattern a] -> Pattern a -> PatternM Bool-useful ps p = usefulMaranget [[p'] | p' <- ps] [p]+useful :: PatternEnv -> [Pattern a] -> Pattern a -> Bool+useful env ps p = usefulMaranget env [[p'] | p' <- ps] [p] sanityFailed :: a sanityFailed = error "Sanity check failed! Perhaps you ran the pattern match exhaustiveness checker on an ill-typed program?"@@ -126,12 +124,12 @@ extrCons _ = [] -- Is the first column of the pattern matrix complete?-fstComplete :: [[Pattern a]] -> PatternM (Complete ())-fstComplete ps = {-# SCC "fstComplete" #-}+fstComplete :: PatternEnv -> [[Pattern a]] -> Complete ()+fstComplete env ps = {-# SCC "fstComplete" #-} if maxTupleLength > 0- then pure $ CompleteTuple maxTupleLength+ then CompleteTuple maxTupleLength else maybe NotComplete CompleteTags- <$> isCompleteSet (concatMap extrCons fstColumn)+ $ isCompleteSet env (concatMap extrCons fstColumn) where fstColumn = fmap head ps tuple (PatternTuple _ ps') = length ps' tuple (OrPattern _ ps') = maximum (tuple <$> ps')@@ -139,18 +137,18 @@ maxTupleLength = maximum (tuple <$> fstColumn) -- follows maranget paper-usefulMaranget :: [[Pattern a]] -> [Pattern a] -> PatternM Bool-usefulMaranget [] _ = pure True-usefulMaranget _ [] = pure False-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:qs) = do -- var or wildcard- cont <- fstComplete ps+usefulMaranget :: PatternEnv -> [[Pattern a]] -> [Pattern a] -> Bool+usefulMaranget _ [] _ = True+usefulMaranget _ _ [] = False+usefulMaranget env ps (PatternCons _ c:qs) = usefulMaranget env (specializeTag c ps) qs+usefulMaranget env ps (PatternTuple _ ps':qs) = usefulMaranget env (specializeTuple (length ps') ps) (toList ps' ++ qs)+usefulMaranget env ps (OrPattern _ ps':qs) = any (\p -> usefulMaranget env ps (p:qs)) ps'+usefulMaranget env ps (q:qs) = -- var or wildcard+ let cont = fstComplete env ps in 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))+ NotComplete -> usefulMaranget env (defaultMatrix ps) qs+ CompleteTuple n -> usefulMaranget env (specializeTuple n ps) (specializeTupleVector n q qs)+ CompleteTags ns -> or $ fmap (\n -> usefulMaranget env (specializeTag n (forget ps)) (fmap void qs)) ns specializeTupleVector :: Int -> Pattern a -> [Pattern a] -> [Pattern a] specializeTupleVector n p ps = {-# SCC "specializeTupleVector" #-} replicate n p ++ ps