diff --git a/Singletons/Lib.hs b/Singletons/Lib.hs --- a/Singletons/Lib.hs +++ b/Singletons/Lib.hs @@ -15,6 +15,7 @@ FlexibleContexts, RankNTypes, UndecidableInstances, FlexibleInstances, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Singletons.Lib ( Any, diff --git a/Singletons/Promote.hs b/Singletons/Promote.hs --- a/Singletons/Promote.hs +++ b/Singletons/Promote.hs @@ -172,8 +172,8 @@ newDecls' = foldl (\decls name -> filter (not . (containsName name)) decls) (concat newDecls) (noTypeSigs ++ noTypeSigsPro) - mapM_ (\n -> report False $ "No type binding for " ++ (show (nameBase n)) ++ - "; removing all declarations including it") + mapM_ (\n -> reportWarning $ "No type binding for " ++ (show (nameBase n)) ++ + "; removing all declarations including it") noTypeSigs return (newDecls' ++ moreNewDecls, noTypeSigs) @@ -412,10 +412,10 @@ promoteTopLevelPat (ParensP _) = fail "Unresolved infix constructors not supported" promoteTopLevelPat (TildeP pat) = do - lift $ report False "Lazy pattern converted into regular pattern in promotion" + lift $ reportWarning "Lazy pattern converted into regular pattern in promotion" promoteTopLevelPat pat promoteTopLevelPat (BangP pat) = do - lift $ report False "Strict pattern converted into regular pattern in promotion" + lift $ reportWarning "Strict pattern converted into regular pattern in promotion" promoteTopLevelPat pat promoteTopLevelPat (AsP name pat) = fail "Promotion of aliased patterns at top level not yet supported" @@ -434,8 +434,8 @@ LHS raw nm (hole . (AppT headTyFam) . extractFn)) lhss)) id promotedPats promoteTopLevelPat (SigP pat _) = do - lift $ report False $ "Promotion of explicit type annotation in pattern " ++ - "not yet supported." + lift $ reportWarning $ "Promotion of explicit type annotation in pattern " ++ + "not yet supported." promoteTopLevelPat pat promoteTopLevelPat (ViewP _ _) = fail "Promotion of view patterns not yet supported" @@ -464,10 +464,10 @@ promotePat (UInfixP _ _ _) = fail "Unresolved infix constructions not supported" promotePat (ParensP _) = fail "Unresolved infix constructions not supported" promotePat (TildeP pat) = do - lift $ report False "Lazy pattern converted into regular pattern in promotion" + lift $ reportWarning "Lazy pattern converted into regular pattern in promotion" promotePat pat promotePat (BangP pat) = do - lift $ report False "Strict pattern converted into regular pattern in promotion" + lift $ reportWarning "Strict pattern converted into regular pattern in promotion" promotePat pat promotePat (AsP name pat) = do ty <- promotePat pat @@ -481,8 +481,8 @@ types <- mapM promotePat pats return $ foldr (\h t -> AppT (AppT PromotedConsT h) t) PromotedNilT types promotePat (SigP pat _) = do - lift $ report False $ "Promotion of explicit type annotation in pattern " ++ - "not yet supported" + lift $ reportWarning $ "Promotion of explicit type annotation in pattern " ++ + "not yet supported" promotePat pat promotePat (ViewP _ _) = fail "View patterns not yet supported" @@ -516,6 +516,8 @@ promoteExp vars (ParensE _) = fail "Promotion of unresolved parens not supported" promoteExp vars (LamE pats exp) = fail "Promotion of lambda expressions not yet supported" +promoteExp vars (LamCaseE alts) = + fail "Promotion of lambda-case expressions not yet supported" promoteExp vars (TupE exps) = do tys <- mapM (promoteExp vars) exps let tuple = PromotedTupleT (length tys) @@ -525,6 +527,8 @@ promoteExp vars (CondE bexp texp fexp) = do tys <- mapM (promoteExp vars) [bexp, texp, fexp] return $ foldType ifTyFam tys +promoteExp vars (MultiIfE alts) = + fail "Promotion of multi-way if not yet supported" promoteExp vars (LetE decs exp) = fail "Promotion of let statements not yet supported" promoteExp vars (CaseE exp matches) = diff --git a/Singletons/Singletons.hs b/Singletons/Singletons.hs --- a/Singletons/Singletons.hs +++ b/Singletons/Singletons.hs @@ -11,8 +11,7 @@ module Singletons.Singletons where -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax hiding (lift) +import Language.Haskell.TH import Singletons.Util import Singletons.Promote import qualified Data.Map as Map @@ -250,8 +249,8 @@ return [SigD (singValName name) (tyTrans (promoteVal name))] singDec (ForeignD fgn) = let name = extractName fgn in do - report False $ "Singling of foreign functions not supported -- " ++ - (show name) ++ " ignored" + reportWarning $ "Singling of foreign functions not supported -- " ++ + (show name) ++ " ignored" return [] where extractName :: Foreign -> Name extractName (ImportF _ _ _ n _) = n @@ -261,8 +260,8 @@ | otherwise = return [InfixD fixity (singValName name)] singDec (PragmaD prag) = let name = extractName prag in do - report False $ "Singling of pragmas not supported -- " ++ - (show name) ++ " ignored" + reportWarning $ "Singling of pragmas not supported -- " ++ + (show name) ++ " ignored" return [] where extractName :: Pragma -> Name extractName (InlineP n _) = n @@ -568,6 +567,8 @@ (pats', vartbl) <- evalForPair $ mapM (singPat Parameter) pats let vars' = Map.union vartbl vars -- order matters; union is left-biased singExp vars' exp +singExp vars (LamCaseE matches) = + fail "Singling of case expressions not yet supported" singExp vars (TupE exps) = do sExps <- mapM (singExp vars) exps sTuple <- singExp vars (ConE (tupleDataName (length exps))) @@ -577,6 +578,8 @@ singExp vars (CondE bexp texp fexp) = do exps <- mapM (singExp vars) [bexp, texp, fexp] return $ foldExp (VarE sIfName) exps +singExp vars (MultiIfE alts) = + fail "Singling of multi-way if statements not yet supported" singExp vars (LetE decs exp) = fail "Singling of let expressions not yet supported" singExp vars (CaseE exp matches) = diff --git a/Singletons/Util.hs b/Singletons/Util.hs --- a/Singletons/Util.hs +++ b/Singletons/Util.hs @@ -7,6 +7,8 @@ Users of the package should not need to consult this file. -} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + module Singletons.Util where import Language.Haskell.TH diff --git a/singletons.cabal b/singletons.cabal --- a/singletons.cabal +++ b/singletons.cabal @@ -1,5 +1,5 @@ name: singletons -version: 0.8 +version: 0.8.1 cabal-version: >= 1.8 synopsis: A framework for generating singleton types homepage: http://www.cis.upenn.edu/~eir/packages/singletons @@ -28,7 +28,7 @@ build-depends: base >= 4 && < 5, mtl >= 2.1.1, - template-haskell, + template-haskell >= 2.8, containers >= 0.5, syb >= 0.3 exposed-modules: Singletons.Lib, Singletons.CustomStar,