kempe 0.1.0.0 → 0.1.0.1
raw patch · 13 files changed
+175/−12 lines, 13 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Kempe.AST: [patternKind] :: Pattern c b -> c
+ Kempe.AST: [patternName] :: Pattern c b -> TyName c
+ Kempe.Check.Pattern: checkModuleExhaustive :: Module a c b -> Maybe (Error b)
Files
- CHANGELOG.md +6/−0
- README.md +1/−3
- bench/Bench.hs +6/−0
- docs/manual.pdf binary
- kempe.cabal +3/−1
- src/Data/Foldable/Ext.hs +6/−1
- src/Kempe/AST.hs +18/−4
- src/Kempe/Check/Pattern.hs +100/−0
- src/Kempe/Check/Restrict.hs +15/−0
- src/Kempe/Error.hs +9/−0
- src/Kempe/File.hs +5/−1
- src/Kempe/Shuttle.hs +5/−2
- test/Type.hs +1/−0
CHANGELOG.md view
@@ -1,5 +1,11 @@ # kempe +## 0.1.0.1++ * Better debug pretty-printer+ * Pattern match exchaustiveness checker so that pattern matches don't do+ something heinous at runtime+ ## 0.1.0.0 Initial release
README.md view
@@ -6,7 +6,7 @@ Inspiration is primarily from [Mirth](https://github.com/mirth-lang/mirth). See manual-[here](http://hackage.haskell.org/package/kempe/src/doc/manual.pdf).+[here](http://hackage.haskell.org/package/kempe/src/docs/manual.pdf). ## Installation @@ -28,8 +28,6 @@ * Unification takes too long * Errors don't have position information * Monomorphization fails on recursive polymorphic functions- * If pattern matches fail at runtime, code just keeps running with whatever- was after the jumps (no pattern match exhaustiveness checker) * Can't export or call C functions with more than 6 arguments; can't call or export large arguments (i.e. structs) passed by value.
bench/Bench.hs view
@@ -9,6 +9,7 @@ import Kempe.Asm.X86.ControlFlow import Kempe.Asm.X86.Linear import Kempe.Asm.X86.Liveness+import Kempe.Check.Pattern import Kempe.File import Kempe.IR import Kempe.IR.Opt@@ -43,6 +44,10 @@ , bench "closedModule" $ nf (runSpecialize =<<) (runAssign p) , bench "closure" $ nf (\m -> closure (m, mkModuleMap m)) (bivoid <$> snd p) ]+ , env eitherMod $ \ e ->+ bgroup "Pattern match exhaustiveness checker"+ [ bench "lib/either.kmp" $ nf checkModuleExhaustive e+ ] , env parsedInteresting $ \ ~(f, n) -> bgroup "Inliner" [ bench "examples/factorial.kmp" $ nf inline (snd f)@@ -96,6 +101,7 @@ splitmix = yeetIO . parseWithMax =<< BSL.readFile "examples/splitmix.kmp" fac = yeetIO . parseWithMax =<< BSL.readFile "examples/factorial.kmp" num = yeetIO . parseWithMax =<< BSL.readFile "lib/numbertheory.kmp"+ eitherMod = yeetIO . parse =<< BSL.readFile "lib/either.kmp" parsedInteresting = (,) <$> fac <*> num prelude = yeetIO . parseWithMax =<< BSL.readFile "prelude/fn.kmp" forTyEnv = (,,) <$> parsedM <*> splitmix <*> prelude
docs/manual.pdf view
binary file changed (211605 → 211830 bytes)
kempe.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: kempe-version: 0.1.0.0+version: 0.1.0.1 license: BSD-3-Clause license-file: LICENSE copyright: Copyright: (c) 2020 Vanessa McHale@@ -40,6 +40,7 @@ Kempe.Pipeline Kempe.Shuttle Kempe.Inline+ Kempe.Check.Pattern Kempe.IR Kempe.IR.Opt Kempe.Asm.X86@@ -49,6 +50,7 @@ hs-source-dirs: src other-modules:+ Kempe.Check.Restrict Kempe.Unique Kempe.Name Kempe.Error
src/Data/Foldable/Ext.hs view
@@ -1,7 +1,12 @@ module Data.Foldable.Ext ( foldMapA+ , foldMapAlternative ) where -import Data.Foldable (fold)+import Control.Applicative (Alternative)+import Data.Foldable (asum, fold)++foldMapAlternative :: (Traversable t, Alternative f) => (a -> f b) -> t a -> f b+foldMapAlternative f xs = asum (f <$> xs) foldMapA :: (Applicative f, Traversable t, Monoid m) => (a -> f m) -> t a -> f m foldMapA = (fmap fold .) . traverse
src/Kempe/AST.hs view
@@ -34,6 +34,7 @@ import Control.DeepSeq (NFData) import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString.Lazy as BSL+import Data.Foldable (toList) import Data.Functor (void) import Data.Int (Int64, Int8) import qualified Data.IntMap as IM@@ -47,7 +48,8 @@ import Kempe.Name import Kempe.Unique import Numeric.Natural-import Prettyprinter (Doc, Pretty (pretty), align, braces, brackets, colon, concatWith, fillSep, hsep, parens, pipe, sep, (<+>))+import Prettyprinter (Doc, Pretty (pretty), align, braces, brackets, colon, concatWith, fillSep, hsep, parens, pipe, sep, vsep, (<+>))+import Prettyprinter.Ext data BuiltinTy = TyInt | TyBool@@ -100,7 +102,7 @@ pretty (TyApp _ ty ty') = parens (pretty ty <+> pretty ty') data Pattern c b = PatternInt b Integer- | PatternCons c (TyName c) -- a constructed pattern+ | PatternCons { patternKind :: c, patternName :: TyName c } -- a constructed pattern | PatternWildcard b | PatternBool b Bool deriving (Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)@@ -118,6 +120,10 @@ pretty PatternWildcard{} = "_" pretty (PatternCons _ tn) = pretty tn +prettyTypedPattern :: Pattern (StackType ()) (StackType ()) -> Doc ann+prettyTypedPattern (PatternCons ty tn) = parens (pretty tn <+> ":" <+> pretty ty)+prettyTypedPattern p = pretty p+ instance Pretty (Atom c a) where pretty (AtName _ n) = pretty n pretty (Dip _ as) = "dip(" <> fillSep (fmap pretty as) <> ")"@@ -128,7 +134,14 @@ pretty (BoolLit _ b) = pretty b pretty (WordLit _ w) = pretty w <> "u" pretty (Int8Lit _ i) = pretty i <> "i8"+ pretty (Case _ ls) = "case" <+> braces (align (vsep (toList $ fmap (uncurry prettyLeaf) ls))) +prettyLeaf :: Pattern c a -> [Atom c a] -> Doc ann+prettyLeaf p as = pipe <+> pretty p <+> "->" <+> align (fillSep (fmap pretty as))++prettyTypedLeaf :: Pattern (StackType ()) (StackType ()) -> [Atom (StackType ()) (StackType ())] -> Doc ann+prettyTypedLeaf p as = pipe <+> prettyTypedPattern p <+> "->" <+> align (fillSep (fmap prettyTyped as))+ prettyTyped :: Atom (StackType ()) (StackType ()) -> Doc ann prettyTyped (AtName ty n) = parens (pretty n <+> ":" <+> pretty ty) prettyTyped (Dip _ as) = "dip(" <> fillSep (prettyTyped <$> as) <> ")"@@ -139,6 +152,7 @@ prettyTyped (BoolLit _ b) = pretty b prettyTyped (Int8Lit _ i) = pretty i <> "i8" prettyTyped (WordLit _ n) = pretty n <> "u"+prettyTyped (Case _ ls) = "case" <+> braces (align (vsep (toList $ fmap (uncurry prettyTypedLeaf) ls))) data Atom c b = AtName b (Name b) | Case b (NonEmpty (Pattern c b, [Atom c b]))@@ -240,9 +254,9 @@ pretty Kabi = "kabi" prettyKempeDecl :: (Atom c b -> Doc ann) -> KempeDecl a c b -> Doc ann-prettyKempeDecl atomizer (FunDecl _ n is os as) = pretty n <+> ":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <+> "=:" <+> brackets (align (fillSep (atomizer <$> as)))+prettyKempeDecl atomizer (FunDecl _ n is os as) = pretty n <+> align (":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <#> "=:" <+> brackets (align (fillSep (atomizer <$> as)))) prettyKempeDecl _ (Export _ abi n) = "%foreign" <+> pretty abi <+> pretty n-prettyKempeDecl _ (ExtFnDecl _ n is os b) = pretty n <+> ":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <+> "=:" <+> "$cfun" <> pretty (decodeUtf8 b)+prettyKempeDecl _ (ExtFnDecl _ n is os b) = pretty n <+> align (":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <#> "=:" <+> "$cfun" <> pretty (decodeUtf8 b)) prettyKempeDecl _ (TyDecl _ tn ns ls) = "type" <+> pretty tn <+> hsep (fmap pretty ns) <+> braces (concatWith (\x y -> x <+> pipe <+> y) $ fmap (uncurry prettyTyLeaf) ls) instance Pretty (KempeDecl a b c) where
+ src/Kempe/Check/Pattern.hs view
@@ -0,0 +1,100 @@+-- | Check pattern match exhaustiveness, since we don't really handle that in+-- source code.+--+-- This is pretty easy because of how patterns work in Kempe.+--+-- Some of this code is from Dickinson, but we don't need the Maranget approach+-- because the pattern matching is simpler in Kempe.+module Kempe.Check.Pattern ( checkModuleExhaustive+ ) where++import Control.Monad (forM_)+import Control.Monad.State.Strict (State, execState)+import Data.Coerce (coerce)+import Data.Foldable (toList, traverse_)+import Data.Foldable.Ext+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS+import Data.List.NonEmpty (NonEmpty (..))+import Kempe.AST+import Kempe.Error+import Kempe.Name+import Kempe.Unique+import Lens.Micro (Lens')+import Lens.Micro.Mtl (modifying)++checkAtom :: PatternEnv -> Atom c b -> Maybe (Error b)+checkAtom env (Case l ls) =+ if isExhaustive env $ fmap fst ls+ then Nothing+ else Just (InexhaustiveMatch l)+checkAtom _ _ = Nothing++checkDecl :: PatternEnv -> KempeDecl a c b -> Maybe (Error b)+checkDecl env (FunDecl _ _ _ _ as) = foldMapAlternative (checkAtom env) as+checkDecl _ _ = Nothing++checkModule :: PatternEnv -> Module a c b -> Maybe (Error b)+checkModule env = foldMapAlternative (checkDecl env)++checkModuleExhaustive :: Module a c b -> Maybe (Error b)+checkModuleExhaustive m =+ let env = runPatternM $ patternEnvDecls m+ in checkModule env m++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))++type PatternM = State PatternEnv++patternEnvDecls :: Module a c b -> PatternM ()+patternEnvDecls = traverse_ declAdd++declAdd :: KempeDecl a c b -> PatternM ()+declAdd FunDecl{} = pure ()+declAdd ExtFnDecl{} = pure ()+declAdd Export{} = pure ()+declAdd (TyDecl _ (Name _ (Unique i) _) _ ls) = do+ forM_ ls $ \(Name _ (Unique j) _, _) ->+ modifying typesLens (IM.insert j i)+ let cons = IS.fromList $ toList (unUnique . unique . fst <$> ls)+ modifying allConsLens (IM.insert i cons)++runPatternM :: PatternM a -> PatternEnv+runPatternM = flip execState (PatternEnv mempty mempty)++internalError :: a+internalError = error "Internal error: lookup in a PatternEnv failed"++-- given a constructor name, get the IntSet of all constructors of that type+assocUniques :: PatternEnv -> Name a -> IS.IntSet+assocUniques env (Name _ (Unique i) _) =+ let ty = IM.findWithDefault internalError i (types env)+ in IM.findWithDefault internalError ty (allCons env)++hasWildcard :: Foldable t => t (Pattern c b) -> Bool+hasWildcard = any isWildcard where+ isWildcard PatternWildcard{} = True+ isWildcard _ = False++-- | Only works on well-typed stuff+isExhaustive :: PatternEnv -> NonEmpty (Pattern c b) -> Bool+isExhaustive _ (PatternWildcard{}:|_) = True+isExhaustive _ (PatternInt{}:|ps) = hasWildcard ps+isExhaustive _ (PatternBool _ True:|PatternBool _ False:_) = True+isExhaustive _ (PatternBool _ False:|PatternBool _ True:_) = True+isExhaustive _ (PatternBool{}:|ps) = hasWildcard ps+isExhaustive env ps@(PatternCons{}:|_) = isCompleteSet env (fmap patternName ps)++isCompleteSet :: PatternEnv -> NonEmpty (TyName a) -> Bool+isCompleteSet env ns@(n:|_) =+ let allU = assocUniques env n+ ty = coerce (unique <$> toList ns)+ in IS.null (allU IS.\\ IS.fromList ty)
+ src/Kempe/Check/Restrict.hs view
@@ -0,0 +1,15 @@+-- | Check that sum types have <256 constructors+module Kempe.Check.Restrict ( restrictConstructors+ ) where++import Data.Foldable.Ext+import Kempe.AST+import Kempe.Error (Error (FatSumType))++restrictConstructors :: Module a c b -> Maybe (Error a)+restrictConstructors = foldMapAlternative restrictDecl++restrictDecl :: KempeDecl a c b -> Maybe (Error a)+restrictDecl (TyDecl l n _ ls) | length ls > 256 = Just (FatSumType l n)+ | otherwise = Nothing+restrictDecl _ = Nothing
src/Kempe/Error.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Kempe.Error ( Error (..)+ , mErr ) where import Control.DeepSeq (NFData)@@ -24,8 +25,14 @@ | InvalidCImport a (Name a) | IllKinded a (KempeTy a) | BadType a+ | FatSumType a (TyName a)+ | InexhaustiveMatch a deriving (Generic, NFData) +mErr :: Maybe (Error ()) -> Either (Error ()) ()+mErr Nothing = Right ()+mErr (Just err) = Left err+ instance (Pretty a) => Show (Error a) where show = show . pretty @@ -40,5 +47,7 @@ pretty (InvalidCImport _ n) = pretty n <+> "imported functions can have at most one return value" pretty (IllKinded _ ty) = "Ill-kinded type:" <+> squotes (pretty ty) <> ". Note that type variables have kind ⭑ in Kempe." pretty (BadType _) = "All types appearing in a signature must have kind ⭑"+ pretty (FatSumType _ tn) = "Sum type" <+> pretty tn <+> "has too many constructors! Sum types are limited to 256 constructors in Kempe."+ pretty InexhaustiveMatch{} = "Inexhaustive pattern match." instance (Pretty a, Typeable a) => Exception (Error a)
src/Kempe/File.hs view
@@ -13,10 +13,12 @@ import Control.Exception (Exception, throwIO) import Data.Bifunctor (bimap) import qualified Data.ByteString.Lazy as BSL+import Data.Functor (void) import qualified Data.Set as S import Data.Tuple.Extra (fst3) import Kempe.AST import Kempe.Asm.X86.Type+import Kempe.Check.Pattern import Kempe.Error import Kempe.IR import Kempe.Lexer@@ -32,7 +34,9 @@ tcFile fp = do contents <- BSL.readFile fp (maxU, m) <- yeetIO $ parseWithMax contents- pure $ fst <$> runTypeM maxU (checkModule m)+ pure $ do+ void $ runTypeM maxU (checkModule m)+ mErr $ checkModuleExhaustive (void <$> m) yeetIO :: Exception e => Either e a -> IO a yeetIO = either throwIO pure
src/Kempe/Shuttle.hs view
@@ -3,8 +3,9 @@ module Kempe.Shuttle ( monomorphize ) where -import Data.Functor (void)+import Data.Functor (void) import Kempe.AST+import Kempe.Check.Pattern import Kempe.Error import Kempe.Inline import Kempe.Monomorphize@@ -15,7 +16,9 @@ -> Either (Error ()) (Module () (ConsAnn MonoStackType) (StackType ()), (Int, SizeEnv)) inlineAssignFlatten ctx m = do -- check before inlining otherwise users would get weird errors- void $ runTypeM ctx (checkModule m)+ void $ do+ void $ runTypeM ctx (checkModule m)+ mErr $ checkModuleExhaustive (void <$> m) (mTy, i) <- runTypeM ctx (assignModule $ inline m) runMonoM i (flattenModule mTy)
test/Type.hs view
@@ -26,6 +26,7 @@ , tyInfer "lib/gaussian.kmp" , badType "test/err/merge.kmp" "Type a_5 -- Int a_4 is not as general as type a_3 -- a_3 a_3" , badType "test/err/kind.kmp" "Ill-kinded type: '(Maybe_1 Maybe_1)'. Note that type variables have kind \11089 in Kempe."+ , badType "test/err/patternMatch.kmp" "Inexhaustive pattern match." , testAssignment "test/data/ty.kmp" , testAssignment "lib/either.kmp" , testAssignment "prelude/fn.kmp"