packages feed

language-dickinson 1.2.0.0 → 1.3.0.0

raw patch · 16 files changed

+412/−19 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -1,5 +1,10 @@ # dickinson +## 1.3.0.0++  * Linter now reports inexhaustive pattern matches+  * Linter reports redundant patterns+ ## 1.2.0.0    * Remove `dir` subcommand
bench/Bench.hs view
@@ -1,14 +1,15 @@ module Main (main) where -import           Control.Exception                  (throw)-import           Control.Exception.Value            (eitherThrow)-import           Control.Monad                      (void)+import           Control.Exception                   (throw)+import           Control.Exception.Value             (eitherThrow)+import           Control.Monad                       (void) import           Criterion.Main-import           Data.Binary                        (decode, encode)-import qualified Data.ByteString.Lazy               as BSL-import qualified Data.Text                          as T+import           Data.Binary                         (decode, encode)+import qualified Data.ByteString.Lazy                as BSL+import qualified Data.Text                           as T import           Language.Dickinson.Check import           Language.Dickinson.Check.Duplicate+import           Language.Dickinson.Check.Exhaustive import           Language.Dickinson.Check.Internal import           Language.Dickinson.Check.Scope import           Language.Dickinson.Error@@ -59,6 +60,10 @@                     , bench "lib/adjectives.dck" $ nf checkMultiple p'                     , bench "bench/data/multiple.dck" $ nf checkDuplicates p -- TODO: better example                     ]+                , env patternEnv $ \ ~(Dickinson _ p) ->+                  bgroup "pattern match exhaustiveness"+                    [ bench "test/examples/declension.dck" $ nf checkExhaustive p+                    ]                 , bgroup "pipeline"                     [ benchPipeline "examples/shakespeare.dck"                     , benchPipeline "examples/fortune.dck"@@ -112,6 +117,7 @@           checkEnv = (,)             <$> multiParsed             <*> libText+          patternEnv = either throw id . parse <$> BSL.readFile "test/examples/declension.dck"  plainExpr :: (UniqueCtx, Dickinson a) -> Dickinson a plainExpr = fst . uncurry renameDickinson
language-dickinson.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               language-dickinson-version:            1.2.0.0+version:            1.3.0.0 license:            BSD3 license-file:       LICENSE copyright:          Copyright: (c) 2020 Vanessa McHale@@ -97,11 +97,13 @@         Language.Dickinson.Check.Internal         Language.Dickinson.Check.Pattern         Language.Dickinson.Check.Duplicate+        Language.Dickinson.Check.Exhaustive         Language.Dickinson.Unique         Language.Dickinson.File         Language.Dickinson.Pipeline         Language.Dickinson.Import         Language.Dickinson.Lib+        Language.Dickinson.Pattern.Useless         Data.Tuple.Ext         Control.Exception.Value         Data.Text.Prettyprint.Doc.Ext@@ -223,6 +225,7 @@     other-modules:         Eval         Golden+        Pattern         Roundtrip.Compare         TypeCheck         TH
src/Data/List/Ext.hs view
@@ -1,5 +1,6 @@ module Data.List.Ext ( anyA                      , allA+                     , forAnyA                      ) where  -- TODO: does this short-circuit appropriately with state monad?@@ -9,3 +10,6 @@ -- TODO: does this short-circuit appropriately with state monad? allA :: (Traversable t, Applicative f) => (a -> f Bool) -> t a -> f Bool allA p = fmap and . traverse p++forAnyA :: (Traversable t, Applicative f) => t a -> (a -> f Bool) -> f Bool+forAnyA = flip anyA
src/Data/Text/Prettyprint/Doc/Ext.hs view
@@ -22,9 +22,8 @@ import           Data.Semigroup            ((<>)) import qualified Data.Text                 as T import qualified Data.Text.Lazy            as TL-import           Prettyprinter             (Doc, LayoutOptions (LayoutOptions), PageWidth (AvailablePerLine),-                                            Pretty (pretty), SimpleDocStream, concatWith, flatAlt, hardline, indent,-                                            layoutSmart, softline, vsep, (<+>))+import           Prettyprinter             (Doc, LayoutOptions (LayoutOptions), PageWidth (AvailablePerLine), Pretty (pretty), SimpleDocStream, concatWith,+                                            flatAlt, hardline, indent, layoutSmart, softline, vsep, (<+>)) import           Prettyprinter.Render.Text (renderLazy, renderStrict)  infixr 6 <#>
+ src/Language/Dickinson/Check/Exhaustive.hs view
@@ -0,0 +1,71 @@+module Language.Dickinson.Check.Exhaustive ( checkExhaustive+                                           , foliate+                                           ) where++import           Control.Applicative                ((<|>))+import           Data.Foldable                      (toList)+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++checkExhaustive :: [Declaration a] -> Maybe (DickinsonWarning a)+checkExhaustive ds = runPatternM (checkDeclsM ds)++checkDeclsM :: [Declaration a] -> PatternM (Maybe (DickinsonWarning a))+checkDeclsM ds =+    patternEnvDecls ds *>+    mapSumM checkDeclM ds++checkDeclM :: Declaration a -> PatternM (Maybe (DickinsonWarning a))+checkDeclM TyDecl{}       = pure Nothing+checkDeclM (Define _ _ e) = checkExprM e++isExhaustiveM :: [Pattern a] -> a -> PatternM (Maybe (DickinsonWarning a))+isExhaustiveM ps loc = do+    e <- isExhaustive ps+    pure $ if e+        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+        then Nothing+        else Just $ UselessPattern (patAnn p) p++foliate :: [a] -> [([a], a)]+foliate = mapMaybe split . inits+    where split []  = Nothing+          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++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 (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 (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))
src/Language/Dickinson/Error.hs view
@@ -36,6 +36,8 @@  data DickinsonWarning a = MultipleNames a (Name a) -- TODO: throw both?                         | DuplicateStr a T.Text+                        | InexhaustiveMatch a+                        | UselessPattern a (Pattern a)                         deriving (Generic, NFData)  maybeThrow :: MonadError e m => Maybe e -> m ()@@ -66,7 +68,9 @@     show = show . pretty  instance (Pretty a) => Pretty (DickinsonWarning a) where-    pretty (MultipleNames l n) = pretty n <+> "at" <+> pretty l <+> "has already been defined"-    pretty (DuplicateStr l t)  = pretty l <+> "duplicate string" <+> dquotes (pretty t)+    pretty (MultipleNames l n)   = pretty n <+> "at" <+> pretty l <+> "has already been defined"+    pretty (DuplicateStr l t)    = pretty l <+> "duplicate string" <+> dquotes (pretty t)+    pretty (InexhaustiveMatch l) = pretty l <+> "Inexhaustive match in expression"+    pretty (UselessPattern l p)  = pretty l <+> "Pattern" <+> pretty p <+> "is redundant"  instance (Pretty a, Typeable a) => Exception (DickinsonWarning a)
src/Language/Dickinson/File.hs view
@@ -26,6 +26,7 @@ import           Data.Text                            as T import           Language.Dickinson.Check import           Language.Dickinson.Check.Duplicate+import           Language.Dickinson.Check.Exhaustive import           Language.Dickinson.Check.Scope import           Language.Dickinson.Error import           Language.Dickinson.Eval@@ -88,7 +89,7 @@  -- | Run some lints warnFile :: FilePath -> IO ()-warnFile = maybeThrowIO . (\x -> checkDuplicates x <|> checkMultiple x) . modDefs+warnFile = maybeThrowIO . (\x -> checkDuplicates x <|> checkMultiple x <|> checkExhaustive x) . modDefs     <=< eitherThrowIO . parse     <=< BSL.readFile
+ src/Language/Dickinson/Pattern/Useless.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings #-}++-- | This module is loosely based off _Warnings for pattern matching_ by Luc+-- Maranget+module Language.Dickinson.Pattern.Useless ( PatternM+                                          , runPatternM+                                          , isExhaustive+                                          , patternEnvDecls+                                          , useful+                                          -- * Exported for testing+                                          , specializeTuple+                                          , 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           Data.List.Ext+import           Language.Dickinson.Name+import           Language.Dickinson.Type+import           Language.Dickinson.Unique+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+                             , types   :: IM.IntMap Int -- ^ all types indexed by constructor+                             }++allConsLens :: Lens' PatternEnv (IM.IntMap IS.IntSet)+allConsLens f s = fmap (\x -> s { allCons = x }) (f (allCons s))++typesLens :: Lens' PatternEnv (IM.IntMap Int)+typesLens f s = fmap (\x -> s { types = x }) (f (types s))++declAdd :: Declaration a -> PatternM ()+declAdd Define{}         = pure ()+declAdd (TyDecl _ (Name _ (Unique i) _) cs) = do+    forM_ cs $ \(Name _ (Unique j) _) ->+        modifying typesLens (IM.insert j i)+    let cons = IS.fromList $ toList (unUnique . unique <$> cs)+    modifying allConsLens (IM.insert i cons)++patternEnvDecls :: [Declaration a] -> PatternM ()+patternEnvDecls = traverse_ declAdd++type PatternM = State PatternEnv++runPatternM :: PatternM a -> a+runPatternM = flip evalState (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 undefined i (types st)+    pure $ findWithDefault undefined ty (allCons st)++isExhaustive :: [Pattern a] -> PatternM Bool+isExhaustive ps = {-# SCC "isExhaustive" #-} not <$> useful 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)+            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]++sanityFailed :: a+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+    where withRow (PatternCons _ c':ps) | c' == c = [ps]+                                        | otherwise = []+          withRow (PatternTuple{}:_)    = sanityFailed+          withRow (Wildcard{}:ps)       = [ps]+          withRow (PatternVar{}:ps)     = [ps]+          withRow (OrPattern _ rs:ps)   = specializeTag c [r:ps | r <- toList rs] -- TODO: unit test case for this+          withRow []                    = emptySpecialize++specializeTuple :: Int -> [[Pattern a]] -> [[Pattern a]]+specializeTuple n = {-# SCC "specializeTuple" #-} 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']+          withRow (OrPattern _ rs:ps)     = specializeTuple n [r:ps | r <- toList rs]+          withRow (PatternCons{}:_)       = sanityFailed+          withRow []                      = emptySpecialize++emptySpecialize :: a+emptySpecialize = error "Internal error: tried to take specialized matrix of an empty row"++-- | \\( \matcal(D) \\) in the Maranget paper+defaultMatrix :: [[Pattern a]] -> [[Pattern a]]+defaultMatrix = {-# SCC "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{}:_)   = []+    withRow (Wildcard{}:ps)     = [ps]+    withRow (PatternVar{}:ps)   = [ps]+    withRow (OrPattern _ rs:ps) = defaultMatrix [r:ps | r <- toList rs]++data Complete a = NotComplete+                | CompleteTuple Int+                | CompleteTags [Name a]++extrCons :: Pattern a -> [Name a]+extrCons (PatternCons _ c) = [c]+extrCons (OrPattern _ ps)  = concatMap extrCons (toList ps)+extrCons _                 = []++-- Is the first column of the pattern matrix complete?+fstComplete :: [[Pattern a]] -> PatternM (Complete ())+fstComplete ps = {-# SCC "fstComplete" #-}+    if maxTupleLength > 0+        then pure $ CompleteTuple maxTupleLength+        else do+            res <- isCompleteSet (concatMap extrCons fstColumn)+            pure $ case res of+                Just ns -> CompleteTags ns+                Nothing -> NotComplete+    where fstColumn = fmap head ps+          tuple (PatternTuple _ ps') = length ps'+          tuple (OrPattern _ ps')    = maximum (tuple <$> ps')+          tuple _                    = 0+          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@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+    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))++specializeTupleVector :: Int -> Pattern a -> [Pattern a] -> [Pattern a]+specializeTupleVector n p ps = {-# SCC "specializeTupleVector" #-} replicate n p ++ ps++forget :: [[Pattern a]] -> [[Pattern ()]]+forget = fmap (fmap void)
src/Language/Dickinson/Type.hs view
@@ -54,7 +54,7 @@                | PatternCons { patAnn :: a, patCons :: TyName a }                | Wildcard { patAnn :: a }                | OrPattern { patAnn :: a, patOr :: NonEmpty (Pattern a) }-               deriving (Generic, NFData, Binary, Functor, Show, Data)+               deriving (Generic, NFData, Binary, Functor, Eq, Show, Data)  data Expression a = Literal { exprAnn :: a, litText :: T.Text }                   | StrChunk { exprAnn :: a, chunkText :: T.Text }
+ test/Pattern.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++module Pattern ( patternTests+               ) where++import           Data.List.NonEmpty                 (NonEmpty (..))+import           Language.Dickinson.Name+import           Language.Dickinson.Pattern.Useless+import           Language.Dickinson.Type+import           Language.Dickinson.Unique+import           Test.Tasty+import           Test.Tasty.HUnit++patternTests :: TestTree+patternTests = testGroup "Pattern match unit tests"+    [ testSpecializeTuple+    , testSpecializeTag+    ]++-- just tests that they make sense as I understand them+testSpecializeTuple :: TestTree+testSpecializeTuple = testCase "specializeTuple" $ do+    let patternMatrix = [[Wildcard ()]]+        specializedMatrix = specializeTuple 2 patternMatrix+    specializedMatrix @?= [[Wildcard (), Wildcard ()]]++testSpecializeTag :: TestTree+testSpecializeTag = testCase "specializeTag" $ do+    let n0 = Name ("a0" :| []) (Unique 0) ()+        n1 = Name ("a1" :| []) (Unique 1) ()+        patternMatrix = [ [PatternCons () n0, Wildcard ()]+                        , [PatternCons () n1, Wildcard ()]+                        ]+        specializedMatrix = [ [Wildcard ()]+                            ]+    specializeTag n0 patternMatrix @?= specializedMatrix
test/Spec.hs view
@@ -2,15 +2,16 @@  module Main (main) where -import           Control.Exception.Value            (eitherThrow)-import qualified Data.ByteString.Lazy               as BSL-import           Data.Either                        (isRight)-import           Data.List.NonEmpty                 (NonEmpty (..))-import           Data.Maybe                         (isJust, isNothing)+import           Control.Exception.Value             (eitherThrow)+import qualified Data.ByteString.Lazy                as BSL+import           Data.Either                         (isRight)+import           Data.List.NonEmpty                  (NonEmpty (..))+import           Data.Maybe                          (isJust, isNothing) import           Eval import           Golden import           Language.Dickinson.Check import           Language.Dickinson.Check.Duplicate+import           Language.Dickinson.Check.Exhaustive import           Language.Dickinson.Check.Internal import           Language.Dickinson.Check.Pattern import           Language.Dickinson.Check.Scope@@ -22,6 +23,7 @@ import           Language.Dickinson.Rename import           Language.Dickinson.Type import           Language.Dickinson.Unique+import           Pattern import           Test.Tasty import           Test.Tasty.HUnit import           TH@@ -35,6 +37,7 @@             , parserTests             , evalTests             , tcTests+            , patternTests             ]  parserTests :: TestTree@@ -68,6 +71,10 @@         , findPath         , sanityCheckTest "test/data/adt.dck"         , detectSuspiciousPattern "test/error/badMatch.dck"+        , detectBadPattern "test/demo/inexhaustive.dck"+        , noInexhaustive "test/demo/exhaustive.dck"+        , detectBadPattern "test/error/inexhaustivePatternMatch.dck"+        , noInexhaustive "prelude/curry.dck"         , thTests         ] @@ -123,3 +130,17 @@     fmap eitherThrow $ evalIO $ do         ds <- amalgamateRenameM [] fp         sanityCheck ds++noInexhaustive :: FilePath -> TestTree+noInexhaustive fp = testCase "Reports non-sketchy pattern matches" $ do+    (Dickinson _ ds) <- parseNoRename fp+    assertBool fp $ isNothing (checkExhaustive ds)++detectBadPattern :: FilePath -> TestTree+detectBadPattern fp = testCase "Detects sketchy pattern match" $ do+    (Dickinson _ ds) <- parseNoRename fp+    assertBool fp $ isJust (checkExhaustive ds)+++parseNoRename :: FilePath -> IO (Dickinson AlexPosn)+parseNoRename = fmap (eitherThrow . parse) . BSL.readFile
+ test/demo/exhaustive.dck view
@@ -0,0 +1,18 @@+%-++tydecl octit = Zero+             | One+             | Two+             | Three+             | Four+             | Five+             | Six+             | Seven++(:def match+  (:lambda x octit+    (:match x+      [Zero Zero]+      [One One]+      [a x])))+
+ test/demo/inexhaustive.dck view
@@ -0,0 +1,17 @@+%-++tydecl octit = Zero+             | One+             | Two+             | Three+             | Four+             | Five+             | Six+             | Seven++(:def match+  (:lambda x octit+    (:match x+      [Zero "0"]+      [One "1"]+      [Two "2"])))
+ test/demo/redundant.dck view
@@ -0,0 +1,18 @@+%-++tydecl octit = Zero+             | One+             | Two+             | Three+             | Four+             | Five+             | Six+             | Seven++(:def match+  (:lambda x octit+    (:match x+      [Zero Zero]+      [One One]+      [One One]+      [a x])))
+ test/error/inexhaustivePatternMatch.dck view
@@ -0,0 +1,26 @@+%-++tydecl case = Nominative | Accusative | Dative | Genitive | Instrumental++tydecl gender = Masculine | Feminine | Neuter++tydecl number = Singular | Plural++; demonstrative pronouns+; "this" or "these"+(:def decline+  (:lambda x (case, gender, number)+    (:match x+      [(Nominative, Masculine, Singular) "þes"]+      [(Accusative, Masculine, Singular) "þisne"]+      [(Genitive, (Masculine|Neuter), Singular) "þisses"]+      [(Dative, (Masculine|Neuter), Singular) "þissum"]+      [(Instrumental, (Masculine|Neuter), Singular) "þys"]+      [((Nominative|Accusative), Neuter, Singular) "þis"]+      [(Nominative, Feminine, Singular) "þeos"]+      [(Accusative, Feminine, Singular) "þas"]+      [((Genitive|Dative|Instrumental), Feminine, Singular) "þisse"]+      [(Nominative, _, Plural) "þas"]+      [(Genitive, _, Plural) "þissa"]+      [(Dative, _, Plural) "þissum"]+      )))