never executed always true always false

    1 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
    2 
    3 module Conjure.Language.Name where
    4 
    5 -- conjure
    6 import Conjure.Prelude
    7 import Conjure.Bug
    8 import Conjure.Language.Pretty
    9 
   10 -- base
   11 import qualified Data.Semigroup as Semigroup ( (<>) )
   12 
   13 -- text
   14 import qualified Data.Text as T
   15 
   16 -- QuickCheck
   17 import Test.QuickCheck ( Arbitrary(..), choose )
   18 
   19 
   20 data Name = Name Text | MachineName Text Int [Text] | NameMetaVar String
   21     deriving (Show, Data, Typeable, Generic)
   22 
   23 instance Eq Name where
   24     Name x == Name y = x == y
   25     x == y = show (pretty x) == show (pretty y)
   26 
   27 instance Ord Name where
   28     compare (Name x) (Name y) = compare x y
   29     compare x y = compare (show (pretty x)) (show (pretty y))
   30 
   31 instance Serialize Name
   32 instance Hashable  Name
   33 instance ToJSON    Name where toJSON = genericToJSON jsonOptions
   34 instance FromJSON  Name where parseJSON = genericParseJSON jsonOptions
   35 
   36 instance Arbitrary Name where
   37     arbitrary = do
   38         ch <- choose ('a', 'z')
   39         return $ Name $ T.pack [ch]
   40     shrink (Name n) = [ Name (T.drop 1 n) | T.length n > 1 ]
   41     shrink _ = []
   42 
   43 instance IsString Name where
   44     fromString = Name . fromString
   45 
   46 instance Pretty Name where
   47     pretty (Name n) = pretty n
   48     pretty (MachineName base n rest) = pretty base <> pretty n <> hcat (map pretty rest)
   49     pretty (NameMetaVar n) = "&" <> pretty n
   50 
   51 instance Semigroup Name where
   52     (<>) (Name a) (Name b) = Name (mappend a b)
   53     (<>) (MachineName base n rest) (Name new) = MachineName base n (rest++[new])
   54     (<>) (Name a) (MachineName base n rest) = MachineName (mappend a base) n rest
   55     (<>) a b = bug $ "mappend{Name}" <+> vcat [pretty (show a), pretty (show b)]
   56 
   57 instance Monoid Name where
   58     mempty = ""