Fail when using enum syntax with non-Int literals (#364)

Author: bergmark

src/Fay.hs

@@ -20,24 +20,23 @@ module Fay
   ) where
 
 import           Fay.Compiler
-import           Fay.Compiler.Misc                      (ioWarn,
-                                                         printSrcSpanInfo)
+import           Fay.Compiler.Misc                      (ioWarn, printSrcSpanInfo)
 import           Fay.Compiler.Packages
 import           Fay.Compiler.Typecheck
 import qualified Fay.Exts                               as F
 import           Fay.Types
 
 import           Control.Applicative
 import           Control.Monad
-import           Data.Aeson (encode)
-import qualified Data.ByteString.Lazy as L
+import           Data.Aeson                             (encode)
+import qualified Data.ByteString.Lazy                   as L
 import           Data.Default
 import           Data.List
 import           Language.Haskell.Exts.Annotated        (prettyPrint)
 import           Language.Haskell.Exts.Annotated.Syntax
 import           Language.Haskell.Exts.SrcLoc
 import           Paths_fay
-import           SourceMap (generate)
+import           SourceMap                              (generate)
 import           SourceMap.Types
 import           System.FilePath
 
@@ -166,6 +165,7 @@ showCompileError e = case e of
   ShouldBeDesugared s              -> "Expected this to be desugared (this is a bug): " ++ s
   UnableResolveQualified qname     -> "unable to resolve qualified names " ++ prettyPrint qname
   UnsupportedDeclaration d         -> "unsupported declaration: " ++ prettyPrint d
+  UnsupportedEnum{}                -> "only Int is allowed in enum expressions"
   UnsupportedExportSpec es         -> "unsupported export specification: " ++ prettyPrint es
   UnsupportedExpression expr       -> "unsupported expression syntax: " ++ prettyPrint expr
   UnsupportedFieldPattern p        -> "unsupported field pattern: " ++ prettyPrint p

src/Fay/Compiler/Desugar.hs

@@ -6,6 +6,7 @@ module Fay.Compiler.Desugar
   (desugar
   ) where
 
+import           Fay.Exts.NoAnnotation           (unAnn)
 import           Fay.Types                       (CompileError (..))
 
 import           Control.Applicative
@@ -116,10 +117,10 @@ desugarExp ex = case ex of
   Paren l e -> Paren l <$> desugarExp e
   RecConstr l q f -> RecConstr l (desugarQName q) <$> mapM desugarFieldUpdate f
   RecUpdate l e f -> RecUpdate l <$> desugarExp e <*> mapM desugarFieldUpdate f
-  EnumFrom l e -> EnumFrom l <$> desugarExp e
-  EnumFromTo l e1 e2 -> EnumFromTo l <$> desugarExp e1 <*> desugarExp e2
-  EnumFromThen l e1 e2 -> EnumFromThen l <$> desugarExp e1 <*> desugarExp e2
-  EnumFromThenTo l e1 e2 e3 -> EnumFromThenTo l <$> desugarExp e1 <*> desugarExp e2 <*> desugarExp e3
+  e@(EnumFrom l e1) -> checkEnum e >> (EnumFrom l <$> desugarExp e1)
+  e@(EnumFromTo l e1 e2) -> checkEnum e >> (EnumFromTo l <$> desugarExp e1 <*> desugarExp e2)
+  e@(EnumFromThen l e1 e2) -> checkEnum e >> (EnumFromThen l <$> desugarExp e1 <*> desugarExp e2)
+  e@(EnumFromThenTo l e1 e2 e3) -> checkEnum e >> (EnumFromThenTo l <$> desugarExp e1 <*> desugarExp e2 <*> desugarExp e3)
   ListComp l e qs -> ListComp l <$> desugarExp e <*> mapM desugarQualStmt qs
   ParComp l e qqs -> ParComp l <$> desugarExp e <*> mapM (mapM desugarQualStmt) qqs
   ExpTypeSig l e t -> ExpTypeSig l <$> desugarExp e <*> return (desugarType t)
@@ -286,3 +287,32 @@ desugarTupleSec l xs = do
       (rn, re) <- genSlotNames l rest ns
       e' <- desugarExp e
       return (rn, e' : re)
+
+-- | We only have Enum instance for Int, but GHC hard codes [x..y]
+-- syntax to GHC.Base.Enum instead of using our Enum class so we check
+-- for obviously incorrect usages and throw an error on them. This can
+-- only checks literals, but it helps a bit.
+checkEnum :: Exp l -> Desugar ()
+checkEnum exp = case exp of
+  EnumFrom       _ e        -> checkIntOrUnknown [e]
+  EnumFromTo     _ e1 e2    -> checkIntOrUnknown [e1,e2]
+  EnumFromThen   _ e1 e2    -> checkIntOrUnknown [e1,e2]
+  EnumFromThenTo _ e1 e2 e3 -> checkIntOrUnknown [e1,e2,e3]
+  _ -> error "checkEnum: Only for Enums"
+  where
+    checkIntOrUnknown :: [Exp l] -> Desugar ()
+    checkIntOrUnknown es = if any isIntOrUnknown es
+      then return ()
+      else throwError . UnsupportedEnum $ unAnn exp
+    isIntOrUnknown :: Exp l -> Bool
+    isIntOrUnknown e = case e of
+      Con            {} -> False
+      Lit _ Int{}       -> True
+      Lit            {} -> False
+      Tuple          {} -> False
+      List           {} -> False
+      EnumFrom       {} -> False
+      EnumFromTo     {} -> False
+      EnumFromThen   {} -> False
+      EnumFromThenTo {} -> False
+      _                 -> True

src/Fay/Types.hs

@@ -208,6 +208,7 @@ data CompileError
   | ShouldBeDesugared String
   | UnableResolveQualified N.QName
   | UnsupportedDeclaration S.Decl
+  | UnsupportedEnum N.Exp
   | UnsupportedExportSpec N.ExportSpec
   | UnsupportedExpression S.Exp
   | UnsupportedFieldPattern S.PatField

src/tests/Test/Compile.hs

@@ -18,8 +18,7 @@ import           System.Environment
 import           Test.Framework
 import           Test.Framework.Providers.HUnit
 import           Test.Framework.TH
-import           Test.HUnit                      (Assertion, assertBool,
-                                                  assertEqual, assertFailure)
+import           Test.HUnit                      (Assertion, assertBool, assertEqual, assertFailure)
 import           Test.Util
 
 tests :: Test
@@ -97,3 +96,12 @@ case_strictWrapper = do
 defConf :: CompileConfig
 defConf = addConfigDirectoryIncludePaths ["tests/"]
         $ def { configTypecheck = False }
+
+case_charEnum :: Assertion
+case_charEnum = do
+  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment
+  res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/EnumChar.hs" } "tests/Compile/EnumChar.hs"
+  case res of
+    Left UnsupportedEnum{} -> return ()
+    Left l  -> assertFailure $ "Should have failed with UnsupportedEnum, but failed with: " ++ show l
+    Right _ -> assertFailure $ "Should have failed with UnsupportedEnum, but compiled"

tests/Compile/EnumChar.hs

@@ -0,0 +1,9 @@
+module EnumChar where
+
+import           Prelude
+
+f :: [Char]
+f = ['a'..'z']
+
+main :: Fay ()
+main = print f