Housekeeping

src/Base/Chord/Chord.hs

@@ -39,7 +39,7 @@ import Base.Core.Interval
 import Common.Utils (uncurry4, uncurry5)
 
 import Data.Function (on)
-import Data.List (sortBy, zip4, zip5)
+import Data.List (sortBy, zip4, zip5, intercalate)
 import qualified Data.List as L
 import Data.Map as M
 import Data.Maybe (catMaybes, fromJust)
@@ -48,7 +48,11 @@ import Data.Maybe (catMaybes, fromJust)
 -- but with the specific notes as well.
 data Chord = Chord { getSymbol :: ChordSymbol
                    , getNotes :: [Note]
-                   } deriving (Eq, Show)
+                   } deriving (Eq)
+
+instance Show Chord where
+  show c = show (getSymbol c) ++ ", [" ++ intercalate ", " (show <$> getNotes c) ++ "]"
+
 
 -- | A Chord has all the properties of the Chordal typeclass
 instance Chordal Chord where

src/Base/Chord/Diatonic.hs

@@ -82,7 +82,7 @@ diatonicChord scale@(Scale note mode) numNotes degree jumpSize =
 -- | Given a degree, returns a function that creates a diatonic triadic major chord
 -- from a key (i.e. a Note) and the number of notes.
 getMajorFuncChord :: Int -> Note -> Int -> Maybe Chord
-getMajorFuncChord deg key numNotes = diatonicChord (Scale key (modeFrom Ionian [])) numNotes deg 2
+getMajorFuncChord deg key numNotes = diatonicChord (Scale key (fromJust (modeFrom Ionian []))) numNotes deg 2
 
 -- | Given a key and a number of notes, this returns a triadic I chord.
 -- If number of notes is not between 2 and 7, this returns Nothing.

src/Base/Chord/Shape.hs

@@ -26,13 +26,19 @@ import Base.Class.Chordal
 import Base.Scale.Heliotonic
 
 import Data.Set hiding (foldr)
+import Data.List(intercalate)
 
 -- | A ChordShape, e.g. a M7 chord, is a rootless abstract shape.
 data ChordShape = ChordShape { getQuality :: Quality
                              , getHighestNatural :: HighestNatural
                              , getExtensions :: [Extension]
                              , getSus :: Sus
-                             } deriving (Eq, Show)
+                             } deriving (Eq)
+
+instance Show ChordShape where
+  show c = show (getQuality c) ++ show (getHighestNatural c)
+        ++ concat (show <$> getExtensions c) ++ show (getSus c)
+
 
 -- | ChordShape has all the properties of the Chordal typeclass
 instance Chordal ChordShape where

src/Base/Chord/Subs.hs

@@ -34,7 +34,7 @@ import Base.Class.Rooted
 
 import Base.Core.Note
 import Base.Core.Quality.CQuality as CQ
-import Base.Core.Quality.IQuality as IQ
+import Base.Core.Quality.IQuality as IQ hiding (major)
 
 import Base.Core.Interval hiding (getQuality)
 import qualified Base.Core.Interval as I(getQuality)
@@ -53,12 +53,11 @@ import Language.Parser
 -- | Removes the P5 interval from a given chord's note if it exists
 -- and returns the same chord symbol.
 --
--- prop> remove5 (chord, _) == chord
+-- prop> getSymbol $ remove5 chord == getSymbol chord
 --
 -- >>> c = canonicalizeChord $ fromJust $ parseChord "CM7"
--- >>> notes = chordToNotes c
--- >>> remove5 (c, notes)
--- (CM7,[C,E,B])
+-- >>> remove5 (chordFromSymbol c)
+-- CM7, [C, E, B]
 remove5 :: Chord -> Chord
 remove5 chord = updateNotes chord $ toNotes (root chord) $ S.delete (fromJust(intervalFrom Perfect 5)) (toIntervals chord)
   where
@@ -118,33 +117,35 @@ negative key chord = head $ notesToChord newNotes
 -- this transposes the chord by that interval. Because this function
 -- is only used internally by the module, it assumes the intervals are
 -- validly constructed.
--- TODO: Make this a safe, general-purpose, exportable function
-transposeChord :: Chord -> IQ.Quality -> Int -> Chord
-transposeChord chord iQual i =
+transposeChord :: Chord -> Interval -> Chord
+transposeChord chord interval =
   let
-    newChord = transposeToRoot (getSymbol chord )$ respell $ jumpIntervalFromNote (fromJust (intervalFrom iQual i)) $ root chord
+    newChord = transposeToRoot (getSymbol chord )$ respell $ jumpIntervalFromNote interval $ root chord
   in
     chordFromSymbol newChord
 
 -- | Given a dominant chord or a minor 6 chord, this returns
 -- a list of chord substitutions from its diminished family.
 --
 -- >>> c = canonicalizeChord $ fromJust $ parseChord "C7"
--- >>> notes = chordToNotes c
--- >>> dimFamilySub (c, notes)
--- [(Eb7,[Eb,G,Bb,Db]),(Gb7,[Gb,Bb,Db,Fb]),(A7,[A,C#,E,G])]
+-- >>> dimFamilySub (chordFromSymbol c)
+-- [Chord {getSymbol = ChordSymbol {getChordRoot = Eb, getShape = ChordShape {getQuality = , getHighestNatural = 7, getExtensions = [], getSus = }}, getNotes = [Eb,G,Bb,Db]},Chord {getSymbol = ChordSymbol {getChordRoot = Gb, getShape = ChordShape {getQuality = , getHighestNatural = 7, getExtensions = [], getSus = }}, getNotes = [Gb,Bb,Db,Fb]},Chord {getSymbol = ChordSymbol {getChordRoot = A, getShape = ChordShape {getQuality = , getHighestNatural = 7, getExtensions = [], getSus = }}, getNotes = [A,C#,E,G]}]
 dimFamilySub :: Chord -> [Chord]
 dimFamilySub eChord
   |  quality eChord == CQ.Dominant ||
     (quality eChord == CQ.Minor && (fromJust (intervalFrom IQ.Major 6) `member` toIntervals eChord))
-    = [transposeChord eChord IQ.Minor 3, transposeChord eChord (IQ.Diminished 1) 5, transposeChord eChord IQ.Major 6]
+    = [transposeBy IQ.Minor 3, transposeBy (IQ.Diminished 1) 5, transposeBy IQ.Major 6]
   | otherwise = []
+  where
+    transposeBy :: IQ.Quality -> Int -> Chord
+    transposeBy iQual i = transposeChord eChord $ fromJust $ intervalFrom iQual i
+
 
 -- | Returns the same chord, but a tritone away.
 -- If applied twice in a row, returns the same chord:
 -- prop> tritoneSub $ tritoneSub (chord, notes) == (_, notes)
 tritoneSub :: Chord -> Chord
-tritoneSub eChord = transposeChord eChord (IQ.Augmented 1) 4
+tritoneSub eChord = transposeChord eChord $ fromJust $ intervalFrom (IQ.Augmented 1) 4
 
 -- | Given a key, and a chord in the key, this returns
 -- a list of chords that are diatonic functional substitutes.

src/Base/Chord/Symbol.hs

@@ -36,7 +36,11 @@ import Data.Set
 -- a C and a M7 gives us a CM7.
 data ChordSymbol = ChordSymbol { getChordRoot :: Note
                                , getShape :: ChordShape
-                               } deriving (Eq, Show)
+                               } deriving (Eq)
+
+instance Show ChordSymbol where
+  show c = show (getChordRoot c) ++ show (getShape c)
+
 
 -- | ChordSymbol has all the properties of the Chordal typeclass,
 -- most importantly, that it can be converted to a set of intervals.

src/Base/Core/Interval.hs

@@ -44,7 +44,7 @@ import Common.Utils (modByFrom)
 
 import Control.Monad (zipWithM)
 
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, isJust, fromMaybe)
 import Data.Set as S hiding (filter)
 
 -- | Intervals are defined by a quality and a size.
@@ -74,8 +74,6 @@ normalizeIntervalSize = modByFrom 7 1
 -- TODO: This should probably return an Either String Interval (or an error
 -- type in place of String) instead of Maybe Interval, in order to facilitate
 -- more sophisticated error handling / reporting.
---
--- TODO: Make sure diminished and augmented don't get arguments > 11
 intervalFrom :: Quality -> Int -> Maybe Interval
 intervalFrom q s = if normalizedSize `elem` goodSizes then
                      Just Interval { getQuality = q, getSize = normalizedSize }
@@ -161,23 +159,23 @@ instance Invertible Interval where
 -- the interval's distance is increased by that integer without
 -- changing its size.
 --
--- TODO: Figure out what to do if dim and aug < 11 and this function
--- receives an integer argument > 11.
---
 -- prop> intervalToDistance i + x == intervalToDistance (i <+> x)
 -- prop> getSize (i <+> _) == getSize i
 infixl 6 <+>
 (<+>) :: Interval -> Int -> Interval
-Interval iQual i <+> x =
-  Interval (iterate modFunc iQual !! abs x) i
+Interval iQual i <+> x = Interval newQual i
   where
+    unwrapMaybeQ :: (Quality -> Maybe Quality) -> Quality -> Quality
+    unwrapMaybeQ f qual = fromMaybe (baseQuality i) (f qual)
     modFunc =
       case (baseQuality i, signum x) of
         (Perfect, 1)  -> raisePerfect
         (Major, 1)    -> raiseMajor
         (Perfect, -1) -> lowerPerfect
         (Major, -1)   -> lowerMajor
-        (_, 0)         -> id
+        (_, 0)         -> return
+    smartMod = unwrapMaybeQ modFunc
+    newQual = iterate smartMod iQual !! abs x
 
 -- | When subtracting an integer from an interval with this infix operator,
 -- the interval's distance is decreased by that integer without
@@ -252,7 +250,5 @@ nthDegreeIntervals ints n = S.map (|-| noteInterval) ints
   where
    noteInterval = toAscList ints !! (n - 1)
 
-zipToIntervalSet :: [Quality] -> [Int] -> Maybe (Set Interval)
-zipToIntervalSet quals sizes =
-  do ints <- zipWithM intervalFrom quals sizes
-     return $ fromList ints
+zipToIntervalSet :: [Quality] -> [Int] -> Set Interval
+zipToIntervalSet quals sizes = fromList (fromJust . uncurry intervalFrom <$> zip quals sizes)

src/Base/Core/Quality/IQuality.hs

@@ -12,6 +12,11 @@ function to get the base quality of an interval size.
 -}
 module Base.Core.Quality.IQuality
   ( Quality(..)
+  , major
+  , perfect
+  , minor
+  , diminished
+  , augmented
   , baseQuality
   , raisePerfect
   , raiseMajor
@@ -27,9 +32,6 @@ import Common.Utils (modByFrom)
 3. Minor
 4. Diminished (single, doubly, triply, etc.)
 5. Augmented (single, doubly, triply, etc.)
-
-TODO: Make sure that interval qualities are using smart constructors
-so that diminished and augmented only receive integers >= 1.
 -}
 data Quality
  = Major
@@ -48,6 +50,21 @@ instance Show Quality where
   show (Diminished i) = if i == 1 then "dim" else show i ++ "dim"
   show (Augmented i)  = if i == 1 then "aug" else show i ++ "aug"
 
+major :: Quality
+major = Major
+
+perfect :: Quality
+perfect = Perfect
+
+minor :: Quality
+minor = Minor
+
+diminished :: Int -> Maybe Quality
+diminished x = if x > 0 && x < 12 then Just $ Diminished x else Nothing
+
+augmented :: Int -> Maybe Quality
+augmented x = if x > 0 && x < 12 then Just $ Augmented x else Nothing
+
 -- | Given an interval size, we return the base quality, either Perfect or Major
 baseQuality :: Int -> Quality
 baseQuality n
@@ -58,34 +75,34 @@ baseQuality n
 
 -- | Given an interval quality, this raises that quality by a semitone
 -- assuming that its base quality is Perfect.
-raisePerfect :: Quality -> Quality
-raisePerfect Perfect = Augmented 1
-raisePerfect (Augmented x)  = Augmented $ x + 1
-raisePerfect (Diminished 1) = Perfect
-raisePerfect (Diminished x) = Diminished $ x - 1
+raisePerfect :: Quality -> Maybe Quality
+raisePerfect Perfect        = Just $ Augmented 1
+raisePerfect (Augmented x)  = augmented $ x + 1
+raisePerfect (Diminished 1) = Just Perfect
+raisePerfect (Diminished x) = diminished $ x - 1
 
 -- | Given an interval quality, this raises that quality by a semitone
 -- assuming that its base quality is Major.
-raiseMajor :: Quality -> Quality
-raiseMajor Major = Augmented 1
-raiseMajor (Augmented x)  = Augmented $ x + 1
-raiseMajor Minor          = Major
-raiseMajor (Diminished 1) = Minor
-raiseMajor (Diminished x) = Diminished $ x - 1
+raiseMajor :: Quality -> Maybe Quality
+raiseMajor Major          = Just $ Augmented 1
+raiseMajor (Augmented x)  = augmented $ x + 1
+raiseMajor Minor          = Just Major
+raiseMajor (Diminished 1) = Just Minor
+raiseMajor (Diminished x) = diminished $ x - 1
 
 -- | Given an interval quality, this lowers that quality by a semitone
 -- assuming that its base quality is Perfect.
-lowerPerfect :: Quality -> Quality
-lowerPerfect Perfect        = Diminished 1
-lowerPerfect (Diminished x) = Diminished $ x + 1
-lowerPerfect (Augmented 1)  = Perfect
-lowerPerfect (Augmented x)  = Augmented $ x-1
+lowerPerfect :: Quality -> Maybe Quality
+lowerPerfect Perfect        = Just $ Diminished 1
+lowerPerfect (Diminished x) = diminished $ x + 1
+lowerPerfect (Augmented 1)  = Just Perfect
+lowerPerfect (Augmented x)  = augmented $ x-1
 
 -- | Given an interval quality, this lowers that quality by a semitone
 -- assuming that its base quality is Major.
-lowerMajor :: Quality -> Quality
-lowerMajor Major          = Minor
-lowerMajor Minor          = Diminished 1
-lowerMajor (Diminished x) = Diminished $ x + 1
-lowerMajor (Augmented 1)  = Major
-lowerMajor (Augmented x)  = Augmented $ x - 1
+lowerMajor :: Quality -> Maybe Quality
+lowerMajor Major          = Just Minor
+lowerMajor Minor          = Just $ Diminished 1
+lowerMajor (Diminished x) = diminished $ x + 1
+lowerMajor (Augmented 1)  = Just Major
+lowerMajor (Augmented x)  = augmented $ x - 1