Skip to content

Commit 5d8bff1

Browse files
vmchalevmchale
committed
Use pure-er approach down the line
1 parent 8a06d19 commit 5d8bff1

File tree

2 files changed

+73
-79
lines changed

2 files changed

+73
-79
lines changed

‎src/Language/Dickinson/Check/Exhaustive.hs

+39-43
Original file line numberDiff line numberDiff line change
@@ -3,38 +3,36 @@ module Language.Dickinson.Check.Exhaustive ( checkExhaustive
33

44
import Control.Applicative ((<|>))
55
import Data.Foldable (toList)
6+
import Data.Foldable.Ext
67
import Data.List (inits)
78
import Data.Maybe (mapMaybe)
8-
import Language.Dickinson.Check.Common
99
import Language.Dickinson.Error
1010
import Language.Dickinson.Pattern.Useless
1111
import Language.Dickinson.Type
1212

1313
-- | Check that there are no useless pattern clauses and check that the pattern
1414
-- matches are exhaustive
1515
checkExhaustive :: [Declaration a] -> Maybe (DickinsonWarning a)
16-
checkExhaustive ds = runPatternM (checkDeclsM ds)
16+
checkExhaustive = checkDeclsM
1717

18-
checkDeclsM :: [Declaration a] -> PatternM (Maybe (DickinsonWarning a))
18+
checkDeclsM :: [Declaration a] -> Maybe (DickinsonWarning a)
1919
checkDeclsM ds =
20-
patternEnvDecls ds *>
21-
mapSumM checkDeclM ds
20+
let pEnv = runPatternM $ patternEnvDecls ds in
21+
foldMapAlternative (checkDecl pEnv) ds
2222

23-
checkDeclM :: Declaration a -> PatternM (Maybe (DickinsonWarning a))
24-
checkDeclM TyDecl{} = pure Nothing
25-
checkDeclM (Define _ _ e) = checkExprM e
23+
checkDecl :: PatternEnv -> Declaration a -> Maybe (DickinsonWarning a)
24+
checkDecl _ TyDecl{} = Nothing
25+
checkDecl env (Define _ _ e) = checkExpr env e
2626

27-
isExhaustiveM :: [Pattern a] -> a -> PatternM (Maybe (DickinsonWarning a))
28-
isExhaustiveM ps loc = do
29-
e <- isExhaustive ps
30-
pure $ if e
27+
isExhaustiveErr :: PatternEnv -> [Pattern a] -> a -> Maybe (DickinsonWarning a)
28+
isExhaustiveErr env ps loc =
29+
if isExhaustive env ps
3130
then Nothing
3231
else Just $ InexhaustiveMatch loc
3332

34-
uselessErr :: [Pattern a] -> Pattern a -> PatternM (Maybe (DickinsonWarning a))
35-
uselessErr ps p = {-# SCC "uselessErr" #-} do
36-
e <- useful ps p
37-
pure $ if e
33+
uselessErr :: PatternEnv -> [Pattern a] -> Pattern a -> Maybe (DickinsonWarning a)
34+
uselessErr env ps p = {-# SCC "uselessErr" #-}
35+
if useful env ps p
3836
then Nothing
3937
else Just $ UselessPattern (patAnn p) p
4038

@@ -44,31 +42,29 @@ foliate = mapMaybe split . inits
4442
split [_] = Nothing
4543
split xs = Just (init xs, last xs)
4644

47-
checkMatch :: [Pattern a] -> a -> PatternM (Maybe (DickinsonWarning a))
48-
checkMatch ps loc = {-# SCC "checkMatch" #-}
49-
(<|>)
50-
<$> mapSumM (uncurry uselessErr) ({-# SCC "foliate" #-} foliate ps)
51-
<*> isExhaustiveM ps loc
45+
checkMatch :: PatternEnv -> [Pattern a] -> a -> Maybe (DickinsonWarning a)
46+
checkMatch env ps loc = {-# SCC "checkMatch" #-}
47+
foldMapAlternative (uncurry (uselessErr env)) ({-# SCC "foliate" #-} foliate ps)
48+
<|> isExhaustiveErr env ps loc
5249

53-
checkExprM :: Expression a -> PatternM (Maybe (DickinsonWarning a))
54-
checkExprM Var{} = pure Nothing
55-
checkExprM Literal{} = pure Nothing
56-
checkExprM StrChunk{} = pure Nothing
57-
checkExprM Constructor{} = pure Nothing
58-
checkExprM BuiltinFn{} = pure Nothing
59-
checkExprM Random{} = pure Nothing
60-
checkExprM (Flatten _ e) = checkExprM e
61-
checkExprM (Annot _ e _) = checkExprM e
62-
checkExprM (Lambda _ _ _ e) = checkExprM e
63-
checkExprM (Choice _ brs) = mapSumM checkExprM (snd <$> brs)
64-
checkExprM (Let _ brs e) = (<|>) <$> mapSumM checkExprM (snd <$> brs) <*> checkExprM e
65-
checkExprM (Bind _ brs e) = (<|>) <$> mapSumM checkExprM (snd <$> brs) <*> checkExprM e
66-
checkExprM (Interp _ es) = mapSumM checkExprM es
67-
checkExprM (MultiInterp _ es) = mapSumM checkExprM es
68-
checkExprM (Apply _ e e') = (<|>) <$> checkExprM e <*> checkExprM e'
69-
checkExprM (Concat _ es) = mapSumM checkExprM es
70-
checkExprM (Tuple _ es) = mapSumM checkExprM es
71-
checkExprM (Match l e brs) =
72-
(<|>)
73-
<$> checkExprM e
74-
<*> ((<|>) <$> checkMatch (toList (fst <$> brs)) l <*> mapSumM checkExprM (snd <$> brs))
50+
checkExpr :: PatternEnv -> Expression a -> Maybe (DickinsonWarning a)
51+
checkExpr _ Var{} = Nothing
52+
checkExpr _ Literal{} = Nothing
53+
checkExpr _ StrChunk{} = Nothing
54+
checkExpr _ Constructor{} = Nothing
55+
checkExpr _ BuiltinFn{} = Nothing
56+
checkExpr _ Random{} = Nothing
57+
checkExpr env (Flatten _ e) = checkExpr env e
58+
checkExpr env (Annot _ e _) = checkExpr env e
59+
checkExpr env (Lambda _ _ _ e) = checkExpr env e
60+
checkExpr env (Choice _ brs) = foldMapAlternative (checkExpr env) (snd <$> brs)
61+
checkExpr env (Let _ brs e) = foldMapAlternative (checkExpr env) (snd <$> brs) <|> checkExpr env e
62+
checkExpr env (Bind _ brs e) = foldMapAlternative (checkExpr env) (snd <$> brs) <|> checkExpr env e
63+
checkExpr env (Interp _ es) = foldMapAlternative (checkExpr env) es
64+
checkExpr env (MultiInterp _ es) = foldMapAlternative (checkExpr env) es
65+
checkExpr env (Apply _ e e') = checkExpr env e <|> checkExpr env e'
66+
checkExpr env (Concat _ es) = foldMapAlternative (checkExpr env) es
67+
checkExpr env (Tuple _ es) = foldMapAlternative (checkExpr env) es
68+
checkExpr env (Match l e brs) =
69+
checkExpr env e
70+
<|> checkMatch env (toList (fst <$> brs)) l <|> foldMapAlternative (checkExpr env) (snd <$> brs)

‎src/Language/Dickinson/Pattern/Useless.hs

+34-36
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
-- | This module is loosely based off /Warnings for pattern matching/ by Luc
44
-- Maranget
55
module Language.Dickinson.Pattern.Useless ( PatternM
6+
, PatternEnv
67
, runPatternM
78
, isExhaustive
89
, patternEnvDecls
@@ -12,15 +13,14 @@ module Language.Dickinson.Pattern.Useless ( PatternM
1213
, specializeTag
1314
) where
1415

15-
import Control.Monad (forM, forM_)
16-
import Control.Monad.State.Strict (State, evalState, get)
16+
import Control.Monad (forM_)
17+
import Control.Monad.State.Strict (State, execState)
1718
import Data.Coerce (coerce)
1819
import Data.Foldable (toList, traverse_)
1920
import Data.Functor (void)
2021
import Data.IntMap.Strict (findWithDefault)
2122
import qualified Data.IntMap.Strict as IM
2223
import qualified Data.IntSet as IS
23-
import Data.List.Ext
2424
import Language.Dickinson.Name
2525
import Language.Dickinson.Type
2626
import Language.Dickinson.Unique
@@ -52,34 +52,32 @@ patternEnvDecls = traverse_ declAdd
5252
-- TODO: just reader monad... writer at beginning?
5353
type PatternM = State PatternEnv
5454

55-
runPatternM :: PatternM a -> a
56-
runPatternM = flip evalState (PatternEnv mempty mempty)
55+
runPatternM :: PatternM a -> PatternEnv
56+
runPatternM = flip execState (PatternEnv mempty mempty)
5757

5858
-- given a constructor name, get the IntSet of all constructors of that type
59-
assocUniques :: Name a -> PatternM IS.IntSet
60-
assocUniques (Name _ (Unique i) _) = {-# SCC "assocUniques" #-} do
61-
st <- get
62-
let ty = findWithDefault internalError i (types st)
63-
pure $ findWithDefault internalError ty (allCons st)
59+
assocUniques :: PatternEnv -> Name a -> IS.IntSet
60+
assocUniques env (Name _ (Unique i) _) = {-# SCC "assocUniques" #-}
61+
let ty = findWithDefault internalError i (types env)
62+
in findWithDefault internalError ty (allCons env)
6463

6564
internalError :: a
6665
internalError = error "Internal error: lookup in a PatternEnv failed"
6766

68-
isExhaustive :: [Pattern a] -> PatternM Bool
69-
isExhaustive ps = {-# SCC "isExhaustive" #-} not <$> useful ps (Wildcard undefined)
67+
isExhaustive :: PatternEnv -> [Pattern a] -> Bool
68+
isExhaustive env ps = {-# SCC "isExhaustive" #-} not $ useful env ps (Wildcard undefined)
7069

71-
isCompleteSet :: [Name a] -> PatternM (Maybe [Name ()])
72-
isCompleteSet [] = pure Nothing
73-
isCompleteSet ns@(n:_) = do
74-
allU <- assocUniques n
75-
let ty = coerce (unique <$> ns)
76-
pure $
77-
if IS.null (allU IS.\\ IS.fromList ty)
70+
isCompleteSet :: PatternEnv -> [Name a] -> Maybe [Name ()]
71+
isCompleteSet _ [] = Nothing
72+
isCompleteSet env ns@(n:_) =
73+
let allU = assocUniques env n
74+
ty = coerce (unique <$> ns)
75+
in if IS.null (allU IS.\\ IS.fromList ty)
7876
then Just ((\u -> Name undefined (Unique u) ()) <$> IS.toList allU)
7977
else Nothing
8078

81-
useful :: [Pattern a] -> Pattern a -> PatternM Bool
82-
useful ps p = usefulMaranget [[p'] | p' <- ps] [p]
79+
useful :: PatternEnv -> [Pattern a] -> Pattern a -> Bool
80+
useful env ps p = usefulMaranget env [[p'] | p' <- ps] [p]
8381

8482
sanityFailed :: a
8583
sanityFailed = error "Sanity check failed! Perhaps you ran the pattern match exhaustiveness checker on an ill-typed program?"
@@ -126,31 +124,31 @@ extrCons (OrPattern _ ps) = concatMap extrCons (toList ps)
126124
extrCons _ = []
127125

128126
-- Is the first column of the pattern matrix complete?
129-
fstComplete :: [[Pattern a]] -> PatternM (Complete ())
130-
fstComplete ps = {-# SCC "fstComplete" #-}
127+
fstComplete :: PatternEnv -> [[Pattern a]] -> Complete ()
128+
fstComplete env ps = {-# SCC "fstComplete" #-}
131129
if maxTupleLength > 0
132-
then pure $ CompleteTuple maxTupleLength
130+
then CompleteTuple maxTupleLength
133131
else maybe NotComplete CompleteTags
134-
<$> isCompleteSet (concatMap extrCons fstColumn)
132+
$ isCompleteSet env (concatMap extrCons fstColumn)
135133
where fstColumn = fmap head ps
136134
tuple (PatternTuple _ ps') = length ps'
137135
tuple (OrPattern _ ps') = maximum (tuple <$> ps')
138136
tuple _ = 0
139137
maxTupleLength = maximum (tuple <$> fstColumn)
140138

141139
-- follows maranget paper
142-
usefulMaranget :: [[Pattern a]] -> [Pattern a] -> PatternM Bool
143-
usefulMaranget [] _ = pure True
144-
usefulMaranget _ [] = pure False
145-
usefulMaranget ps (PatternCons _ c:qs) = usefulMaranget (specializeTag c ps) qs
146-
usefulMaranget ps (PatternTuple _ ps':qs) = usefulMaranget (specializeTuple (length ps') ps) (toList ps' ++ qs)
147-
usefulMaranget ps (OrPattern _ ps':qs) = forAnyA ps' $ \p -> usefulMaranget ps (p:qs)
148-
usefulMaranget ps (q:qs) = do -- var or wildcard
149-
cont <- fstComplete ps
140+
usefulMaranget :: PatternEnv -> [[Pattern a]] -> [Pattern a] -> Bool
141+
usefulMaranget _ [] _ = True
142+
usefulMaranget _ _ [] = False
143+
usefulMaranget env ps (PatternCons _ c:qs) = usefulMaranget env (specializeTag c ps) qs
144+
usefulMaranget env ps (PatternTuple _ ps':qs) = usefulMaranget env (specializeTuple (length ps') ps) (toList ps' ++ qs)
145+
usefulMaranget env ps (OrPattern _ ps':qs) = any (\p -> usefulMaranget env ps (p:qs)) ps'
146+
usefulMaranget env ps (q:qs) = -- var or wildcard
147+
let cont = fstComplete env ps in
150148
case cont of
151-
NotComplete -> usefulMaranget (defaultMatrix ps) qs
152-
CompleteTuple n -> usefulMaranget (specializeTuple n ps) (specializeTupleVector n q qs)
153-
CompleteTags ns -> or <$> forM ns (\n -> usefulMaranget (specializeTag n (forget ps)) (fmap void qs))
149+
NotComplete -> usefulMaranget env (defaultMatrix ps) qs
150+
CompleteTuple n -> usefulMaranget env (specializeTuple n ps) (specializeTupleVector n q qs)
151+
CompleteTags ns -> or $ fmap (\n -> usefulMaranget env (specializeTag n (forget ps)) (fmap void qs)) ns
154152

155153
specializeTupleVector :: Int -> Pattern a -> [Pattern a] -> [Pattern a]
156154
specializeTupleVector n p ps = {-# SCC "specializeTupleVector" #-} replicate n p ++ ps

0 commit comments

Comments
 (0)