{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

-- | A data type with ten nullary constructors [0-9] and combinators.
module Data.Digit
(
-- * Data type
  Digit
-- * Destructors
, foldDigit
-- * Lenses
, HasDigit(..)
-- * Prisms
, D0(..)
, x0
, D1(..)
, x1
, D2(..)
, x2
, D3(..)
, x3
, D4(..)
, x4
, D5(..)
, x5
, D6(..)
, x6
, D7(..)
, x7
, D8(..)
, x8
, D9(..)
, x9
, digit
, digitC
, digitlist
-- * mod operations
, mod10
, divMod10
-- * Parsers
, parsedigit
, parsedigitlist
, parsedigits
, parsedigitlist1
, skipdigitlist
, skipdigitlist1
, parsenotdigit
, parsenotdigits
, parsenotdigits1
, skipnotdigits
, skipnotdigits1
-- * Quasi-Quoters
, digitQ
-- * Digits
, Digits
, digits
, digitsI
, digitsS
, (/+/)
, (.+.)
, (.*.)
, mantissa
) where

import Control.Applicative(many, some)
import Data.Data (Data)
import Data.Foldable(foldl', asum)
import Data.List(unfoldr)
import Data.List.NonEmpty(some1)
import Data.Maybe(fromMaybe)
import Data.Monoid(mappend)
import Data.Semigroup((<>))
import Data.String(String)
import Data.Typeable (Typeable)
import Language.Haskell.TH(ExpQ, PatQ, varE, varP, mkName)
import Language.Haskell.TH.Quote(QuasiQuoter(QuasiQuoter), quotePat, quoteExp, quoteDec, dataToExpQ, dataToPatQ, quoteType)
import Prelude(fromEnum, Bounded, error) -- livin on the edge
import Text.Parser.Char(CharParsing, char, satisfy)
import Text.Parser.Combinators(skipMany, skipSome, (<?>))
import Papa

-- $setup
-- >>> import Prelude

-- | A data type with ten nullary constructors.
data Digit =
  D0
  | D1
  | D2
  | D3
  | D4
  | D5
  | D6
  | D7
  | D8
  | D9
  deriving (Eq, Ord, Enum, Bounded, Data, Typeable)

-- | Catamorphism for @Digit@.
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D0 == q0
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D1 == q1
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D2 == q2
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D3 == q3
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D4 == q4
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D5 == q5
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D6 == q6
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D7 == q7
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D8 == q8
--
-- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D9 == q9
foldDigit ::
  a -- ^ Zero.
  -> a -- ^ One.
  -> a -- ^ Two.
  -> a -- ^ Three.
  -> a -- ^ Four.
  -> a -- ^ Five.
  -> a -- ^ Six.
  -> a -- ^ Seven.
  -> a -- ^ Eight.
  -> a -- ^ Nine.
  -> Digit -- ^ The digit to fold.
  -> a
foldDigit q0 _  _  _  _  _  _  _  _  _  D0 =
  q0
foldDigit _  q1 _  _  _  _  _  _  _  _  D1 =
  q1
foldDigit _  _  q2 _  _  _  _  _  _  _  D2 =
  q2
foldDigit _  _  _  q3 _  _  _  _  _  _  D3 =
  q3
foldDigit _  _  _  _  q4 _  _  _  _  _  D4 =
  q4
foldDigit _  _  _  _  _  q5 _  _  _  _  D5 =
  q5
foldDigit _  _  _  _  _  _  q6 _  _  _  D6 =
  q6
foldDigit _  _  _  _  _  _  _  q7 _  _  D7 =
  q7
foldDigit _  _  _  _  _  _  _  _  q8 _  D8 =
  q8
foldDigit _  _  _  _  _  _  _  _  _  q9 D9 =
  q9

class HasDigit a where
  hasdigit ::
    Lens' a Digit

instance HasDigit Digit where
  hasdigit =
    id

class D0 d where
  d0 ::
    Prism'
      d
      ()

instance D0 Digit where
  d0 =
    prism'
      (\() -> D0)
      (\d -> case d of
               D0 -> Just ()
               _ -> Nothing)

x0 ::
  D0 d =>
  d
x0 =
  d0 # ()

class D1 d where
  d1 ::
    Prism'
      d
      ()

instance D1 Digit where
  d1 =
    prism'
      (\() -> D1)
      (\d -> case d of
               D1 -> Just ()
               _ -> Nothing)

x1 ::
  D1 d =>
  d
x1 =
  d1 # ()

class D2 d where
  d2 ::
    Prism'
      d
      ()

instance D2 Digit where
  d2 =
    prism'
      (\() -> D2)
      (\d -> case d of
               D2 -> Just ()
               _ -> Nothing)

x2 ::
  D2 d =>
  d
x2 =
  d2 # ()

class D3 d where
  d3 ::
    Prism'
      d
      ()

instance D3 Digit where
  d3 =
    prism'
      (\() -> D3)
      (\d -> case d of
               D3 -> Just ()
               _ -> Nothing)

x3 ::
  D3 d =>
  d
x3 =
  d3 # ()

class D4 d where
  d4 ::
    Prism'
      d
      ()

instance D4 Digit where
  d4 =
    prism'
      (\() -> D4)
      (\d -> case d of
               D4 -> Just ()
               _ -> Nothing)

x4 ::
  D4 d =>
  d
x4 =
  d4 # ()

class D5 d where
  d5 ::
    Prism'
      d
      ()

instance D5 Digit where
  d5 =
    prism'
      (\() -> D5)
      (\d -> case d of
               D5 -> Just ()
               _ -> Nothing)

x5 ::
  D5 d =>
  d
x5 =
  d5 # ()

class D6 d where
  d6 ::
    Prism'
      d
      ()

instance D6 Digit where
  d6 =
    prism'
      (\() -> D6)
      (\d -> case d of
               D6 -> Just ()
               _ -> Nothing)

x6 ::
  D6 d =>
  d
x6 =
  d6 # ()

class D7 d where
  d7 ::
    Prism'
      d
      ()

instance D7 Digit where
  d7 =
    prism'
      (\() -> D7)
      (\d -> case d of
               D7 -> Just ()
               _ -> Nothing)

x7 ::
  D7 d =>
  d
x7 =
  d7 # ()

class D8 d where
  d8 ::
    Prism'
      d
      ()

instance D8 Digit where
  d8 =
    prism'
      (\() -> D8)
      (\d -> case d of
               D8 -> Just ()
               _ -> Nothing)

x8 ::
  D8 d =>
  d
x8 =
  d8 # ()

class D9 d where
  d9 ::
    Prism'
      d
      ()

instance D9 Digit where
  d9 =
    prism'
      (\() -> D9)
      (\d -> case d of
               D9 -> Just ()
               _ -> Nothing)

x9 ::
  D9 d =>
  d
x9 =
  d9 # ()

-- | A prism for using @Int@ as @Digit@.
--
-- >>> 5 ^? digit
-- Just 5
--
-- >>> 0 ^? digit
-- Just 0
--
-- >>> 9 ^? digit
-- Just 9
--
-- >>> 10 ^? digit
-- Nothing
--
-- >>> (-5) ^? digit
-- Nothing
--
-- >>> digit # D5
-- 5
--
-- >>> digit # D9
-- 9
--
-- >>> digit # D0
-- 0
digit ::
  Integral a =>
  Prism' a Digit
digit =
  prism'
    (\n -> case n of D0 -> 0
                     D1 -> 1
                     D2 -> 2
                     D3 -> 3
                     D4 -> 4
                     D5 -> 5
                     D6 -> 6
                     D7 -> 7
                     D8 -> 8
                     D9 -> 9)

    (\n -> case n of 0 -> Just D0
                     1 -> Just D1
                     2 -> Just D2
                     3 -> Just D3
                     4 -> Just D4
                     5 -> Just D5
                     6 -> Just D6
                     7 -> Just D7
                     8 -> Just D8
                     9 -> Just D9
                     _ -> Nothing)

-- | A prism for using @Char@ as @Digit@.
--
-- >>> '5' ^? digitC
-- Just 5
--
-- >>> '0' ^? digitC
-- Just 0
--
-- >>> '9' ^? digitC
-- Just 9
--
-- >>> 'a' ^? digitC
-- Nothing
--
-- >>> '@' ^? digitC
-- Nothing
--
-- >>> digitC # D5
-- '5'
--
-- >>> digitC # D9
-- '9'
--
-- >>> digitC # D0
-- '0'
digitC ::
  Prism' Char Digit
digitC =
  prism'
    (\d -> case d of D0 -> '0'
                     D1 -> '1'
                     D2 -> '2'
                     D3 -> '3'
                     D4 -> '4'
                     D5 -> '5'
                     D6 -> '6'
                     D7 -> '7'
                     D8 -> '8'
                     D9 -> '9')
    (\n -> case n of '0' -> Just D0
                     '1' -> Just D1
                     '2' -> Just D2
                     '3' -> Just D3
                     '4' -> Just D4
                     '5' -> Just D5
                     '6' -> Just D6
                     '7' -> Just D7
                     '8' -> Just D8
                     '9' -> Just D9
                     _ -> Nothing)

-- | A prism for the list of digits in an integer
--
-- >>> 1234 ^? digitlist
-- Just [1,2,3,4]
-- 
-- >>> 0 ^? digitlist
-- Just []
-- 
-- >>> 1 ^? digitlist
-- Just [1]
-- 
-- >>> 90 ^? digitlist
-- Just [9,0]
-- 
-- >>> 05 ^? digitlist
-- Just [5]
-- 
-- >>> 105 ^? digitlist
-- Just [1,0,5]
-- 
-- >>> (-1) ^? digitlist
-- Nothing
--
-- λ> digitlist # [D0]
-- 0
--
-- >>> digitlist # [D0, D1]
-- 1
--
-- >>> digitlist # [D1]
-- 1
--
-- >>> digitlist # [D1, D2, D3]
-- 123
--
-- >>> digitlist # [D1, D0, D3]
-- 103
--
-- >>> digitlist # [D1, D0, D3, D0]
-- 1030
digitlist ::
  Integral a =>
  Prism'
    a
    [Digit]
digitlist =
  prism'
    (foldl' (\a b -> a * 10 + digit # b) 0)
    (\i ->  if  i < 0
              then
                Nothing
              else 
                Just (reverse (unfoldr (\n -> 
                  let (x, r) = divMod10 n
                  in  if x == 0
                        then
                          if r == D0
                            then
                              Nothing
                            else
                              Just (r, 0)
                        else
                              Just (r, x)) i))
    )

digits ::
  Integral a =>
  Prism'
    a
    Digits
digits =
  digitlist . digitsI

-- | Modulus with 10.
--
-- >>> mod10 0
-- 0
--
-- >>> mod10 1
-- 1
--
-- >>> mod10 8
-- 8
--
-- >>> mod10 9
-- 9
--
-- >>> mod10 10
-- 0
--
-- >>> mod10 90
-- 0
--
-- >>> mod10 91
-- 1
--
-- >>> mod10 (-1)
-- 9
mod10 ::
  Integral a =>
  a
  -> Digit
mod10 n =
  let r = n `mod` 10
  in fromMaybe (mod10 r) (r ^? digit)

-- | Division/modulus with 10.
--
-- >>> divMod10 0
-- (0,0)
--
-- >>> divMod10 1
-- (0,1)
--
-- >>> divMod10 8
-- (0,8)
--
-- >>> divMod10 9
-- (0,9)
--
-- >>> divMod10 10
-- (1,0)
--
-- >>> divMod10 90
-- (9,0)
--
-- >>> divMod10 91
-- (9,1)
--
-- >>> divMod10 (-1)
-- (-1,9)
divMod10 ::
  Integral a =>
  a
  -> (a, Digit)
divMod10 n =
  let (x, r) = n `divMod` 10
  in (x, mod10 r)

parsedigit ::
  (Monad p, CharParsing p) =>
  p Digit
parsedigit =
  let p = asum ((\d -> d <$ char (digitC # d)) <$> [D0 .. D9])
  in p <?> "digit"

parsedigitlist ::
  (Monad p, CharParsing p) =>
  p [Digit]
parsedigitlist =
  many parsedigit

parsedigits ::
  (Monad p, CharParsing p) =>
  p Digits
parsedigits = 
  Digits <$> parsedigitlist

parsedigitlist1 ::
  (Monad p, CharParsing p) =>
  p (NonEmpty Digit)
parsedigitlist1 =
  some1 parsedigit

skipdigitlist ::
  (Monad p, CharParsing p) =>
  p ()
skipdigitlist =
  skipMany parsedigit

skipdigitlist1 ::
  (Monad p, CharParsing p) =>
  p ()
skipdigitlist1 =
  skipSome parsedigit

parsenotdigit ::
  CharParsing p =>
  p Char
parsenotdigit =
  let p = satisfy (`notElem` ['0' .. '9'])
  in p <?> "not digit"

parsenotdigits ::
  CharParsing p =>
  p String
parsenotdigits =
  many parsenotdigit

parsenotdigits1 ::
  CharParsing p =>
  p String
parsenotdigits1 =
  some parsenotdigit

skipnotdigits ::
  CharParsing p =>
  p ()
skipnotdigits =
  skipMany parsenotdigit

skipnotdigits1 ::
  CharParsing p =>
  p ()
skipnotdigits1 =
  skipSome parsenotdigit

instance Show Digit where
  show = show . fromEnum

-- | A QuasiQuoter for any range of @Digit@.
--
-- [digitQ|4|] :: Digit
-- 4
--
-- named [digitQ|4|]  = "four"
-- named [digitQ|$x|] = "not four, " ++ show x ++ " instead"
--
-- mod10D x = let y = mod x 10 in [digitQ|$y|]
digitQ :: QuasiQuoter
digitQ = QuasiQuoter {
    quoteExp = dexp
  , quotePat = dpat
  , quoteType = error "not quotable"
  , quoteDec = error "not quotable"
  }

dexp :: [Char] -> ExpQ
dexp ('$':vn) = varE (mkName vn)
dexp (d:[])   = maybe (error "not a digit") (dataToExpQ (const Nothing)) (d ^? digitC)
dexp _        = error "not a digit"

dpat :: [Char] -> PatQ
dpat ('$':vn) = varP (mkName vn)
dpat (d:[])   = maybe (error "not a digit") (dataToPatQ (const Nothing)) (d ^? digitC)
dpat _        = error "not a digit"

newtype Digits =
  Digits [Digit]
  deriving (Eq, Ord, Show, Data, Typeable)

digitsI ::
  Iso'
    [Digit]
    Digits
digitsI =
  iso
    Digits
    (\(Digits x) -> x)

digitsS ::
  Prism'
    String
    Digits
digitsS =
  prism'
    (\(Digits d) -> (digitC #) <$> d)
    (\s -> Digits <$> traverse (^? digitC) s)

instance Cons Digits Digits Digit Digit where
  _Cons =
    prism'
      (\(h, Digits t) -> Digits (h:t))
      (\(Digits d) -> case d of 
                        [] ->
                          Nothing
                        (h:t) ->
                          Just (h, Digits t))


instance Snoc Digits Digits Digit Digit where
  _Snoc =
    prism'
      (\(Digits t, z) -> Digits (t ++ [z]))
      (\(Digits d) -> (\(a, b) -> (Digits a, b)) <$> d ^? _Snoc)

instance AsEmpty Digits where
  _Empty =
    prism'
      (\() -> Digits [])
      (\(Digits d) -> case d of
                        [] ->
                          Just ()
                        (_:_) ->
                          Nothing)

instance Each Digits Digits Digit Digit where
  each f (Digits d) =
    Digits <$> each f d

type instance IxValue Digits = Digit
type instance Index Digits = Int
instance Ixed Digits where
  ix i f (Digits d) =
    Digits <$> ix i f d

instance Plated Digits where
  plate f (Digits d) =
    Digits <$> plate (\x -> (\(Digits e) -> e) <$> f (Digits x)) d

instance Reversing Digits where
  reversing (Digits d) =
    Digits (reversing d)

instance Semigroup Digits where
  Digits d <> Digits e =
    Digits (d <> e)

instance Monoid Digits where
  mempty =
    Digits mempty
  mappend =
    (<>)

-- |
--
-- >>> D0 /+/ D0
-- (0,0)
--
-- >>> D0 /+/ D1
-- (0,1)
--
-- >>> D1 /+/ D0
-- (0,1)
--
-- >>> D4 /+/ D5
-- (0,9)
--
-- >>> D5 /+/ D5
-- (1,0)
--
-- >>> D5 /+/ D6
-- (1,1)
--
-- >>> D8 /+/ D7
-- (1,5)
--
-- >>> D9 /+/ D9
-- (1,8)
(/+/) ::
  Digit
  -> Digit
  -> (Digit, Digit)
a /+/ b =
  let (x, r) = divMod10 (digit # a + digit # b)
  in (mod10 (x :: Integer), r) 

-- |
--
--
-- >>> Digits [x2] .+. Digits [x1, x0]
-- Digits [1,2]
--
-- >>> Digits [x1, x2, x3] .+. Digits [x4, x5, x6]
-- Digits [5,7,9]
(.+.) ::
  Digits
  -> Digits
  -> Digits
d .+. e =
  fromMaybe mempty ((digits # d + digits # e :: Integer) ^? digits)

-- |
--
--
-- >>> Digits [x2] .*. Digits [x1, x0]
-- Digits [2,0]
--
-- >>> Digits [x1, x2, x3] .*. Digits [x4, x5, x6]
-- Digits [5,6,0,8,8]
(.*.) ::
  Digits
  -> Digits
  -> Digits
d .*. e =
  fromMaybe mempty ((digits # d * digits # e :: Integer) ^? digits)

-- |
--
-- >>> mantissa (Digits []) :: Double
-- 0.0
--
-- > mantissa (Digits [x0]) :: Double
-- 0.0
--
-- >>> mantissa (Digits [x1]) :: Double
-- 0.1
--
-- >>> mantissa (Digits [x1, x9]) :: Double
-- 0.19
mantissa ::
  Floating a =>
  Digits
  -> a
mantissa d =
  let acc a (e, x) = 
        a + fromIntegral (digit # x :: Int) * 10 ** fromIntegral (negate e :: Int)
  in foldl' acc 0 (zip [1..] (digitsI # d))