text:
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Plot.Figure.Plot.Data
-- Copyright   :  (c) A. V. H. McPhail 2010
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- 'Data' operations
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Plot.Figure.Plot.Data (
                                                 Data
                                                 -- * Series data
                                                , FormattedSeries()
                                                , line, point, linepoint
                                                , impulse, step
                                                , area
                                                , bar
                                                , hist
                                                , candle, whisker
                                                , setDataSeries
                                                -- * Plot type
                                                , setSeriesType
                                                , setAllSeriesTypes
                                                -- * Formatting
                                                , PlotFormats(..)
                                                , withSeriesFormat
                                                , withAllSeriesFormats
                                                -- * Internal
                                                , Abscissa(), Ordinate(), Dataset()
                                                ) where

-----------------------------------------------------------------------------

import Numeric.LinearAlgebra.Data hiding (format,step)
import Numeric.LinearAlgebra.Devel

import Data.Maybe

import qualified Data.Array.IArray as A

import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Supply
import Control.Monad.Trans.Maybe

import Graphics.Rendering.Plot.Types
import Graphics.Rendering.Plot.Figure.Line
import Graphics.Rendering.Plot.Figure.Point
import Graphics.Rendering.Plot.Figure.Bar

-----------------------------------------------------------------------------

dataSeriesNum :: DataSeries -> Int
dataSeriesNum (DS_Y a)      = A.rangeSize $ A.bounds $ a
dataSeriesNum (DS_1toN _ a) = A.rangeSize $ A.bounds $ a
dataSeriesNum (DS_1to1 a)   = A.rangeSize $ A.bounds $ a
dataSeriesNum (DS_Surf _)   = 1

-----------------------------------------------------------------------------

class SeriesTypes a where
    setSeriesType'' :: SeriesType -> a -> Data a

instance SeriesTypes Decoration where
    setSeriesType'' Line      d@(DecLine _)    = return d
    setSeriesType'' Line      (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Line      (DecLinPt lt _)  = return $ DecLine lt
    setSeriesType'' Line      (DecImpulse lt)  = return $ DecLine lt
    setSeriesType'' Line      (DecStep lt)     = return $ DecLine lt
    setSeriesType'' Line      (DecArea lt)     = return $ DecLine lt
    setSeriesType'' Line      (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Line      (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Line      (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Line      (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecLine lt
    setSeriesType'' Point     (DecLine lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     d@(DecPoint _)   = return d
    setSeriesType'' Point     (DecLinPt _ pt)  = return $ DecPoint pt
    setSeriesType'' Point     (DecImpulse lt)  = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecStep lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecArea lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' Point     (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecPoint pt
    setSeriesType'' LinePoint (DecLine lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine (c :: Color)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint d@(DecLinPt _ _) = return d
    setSeriesType'' LinePoint (DecImpulse lt)  = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecStep lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecArea lt)     = do
                                                 let c = fromJust $ getLineColour lt
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' LinePoint (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 g <- supply
                                                 pt <- toPoint (g :: Glyph,c)
                                                 return $ DecLinPt lt pt
    setSeriesType'' Impulse   (DecLine lt)     = return $ DecImpulse lt
    setSeriesType'' Impulse   (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Impulse   (DecLinPt lt _)  = return $ DecImpulse lt
    setSeriesType'' Impulse   d@(DecImpulse _) = return d
    setSeriesType'' Impulse   (DecStep lt)     = return $ DecImpulse lt
    setSeriesType'' Impulse   (DecArea lt)     = return $ DecImpulse lt
    setSeriesType'' Impulse   (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Impulse   (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Impulse   (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Impulse   (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecImpulse lt
    setSeriesType'' Step      (DecLine lt)     = return $ DecStep lt
    setSeriesType'' Step      (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Step      (DecLinPt lt _)  = return $ DecStep lt
    setSeriesType'' Step      (DecImpulse lt)  = return $ DecStep lt
    setSeriesType'' Step      d@(DecStep _)    = return d
    setSeriesType'' Step      (DecArea lt)     = return $ DecStep lt
    setSeriesType'' Step      (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Step      (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Step      (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Step      (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecStep lt
    setSeriesType'' Area      (DecLine lt)     = return $ DecArea lt
    setSeriesType'' Area      (DecPoint pt)    = do
                                                 let c = getPointColour pt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Area      (DecLinPt lt _)  = return $ DecArea lt
    setSeriesType'' Area      (DecImpulse lt)  = return $ DecArea lt
    setSeriesType'' Area      (DecStep lt)     = return $ DecArea lt
    setSeriesType'' Area      d@(DecArea _)    = return d
    setSeriesType'' Area      (DecBar bt)      = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Area      (DecHist bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Area      (DecCand bt)     = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Area      (DecWhisk bt)    = do
                                                 let c = getBarColour bt
                                                 lt <- toLine c
                                                 return $ DecArea lt
    setSeriesType'' Bar      (DecLine lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecPoint pt)     = do
                                                 let c = getPointColour pt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecLinPt lt _)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecImpulse lt)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecStep lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      (DecArea lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecBar bt
    setSeriesType'' Bar      d@(DecBar _)      = return d
    setSeriesType'' Bar      (DecHist bt)      = return $ DecBar bt
    setSeriesType'' Bar      (DecCand bt)      = return $ DecBar bt
    setSeriesType'' Bar      (DecWhisk bt)     = return $ DecBar bt
    setSeriesType'' Hist     (DecLine lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecPoint pt)     = do
                                                 let c = getPointColour pt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecLinPt lt _)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecImpulse lt)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecStep lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecArea lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecHist bt
    setSeriesType'' Hist     (DecBar bt)       = return $ DecHist bt
    setSeriesType'' Hist     d@(DecHist _)     = return d
    setSeriesType'' Hist     (DecCand bt)      = return $ DecHist bt
    setSeriesType'' Hist     (DecWhisk bt)     = return $ DecHist bt
    setSeriesType'' Candle  (DecLine lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecPoint pt)     = do
                                                 let c = getPointColour pt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecLinPt lt _)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecImpulse lt)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecStep lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecArea lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecCand bt
    setSeriesType'' Candle  (DecBar bt)       = return $ DecCand bt
    setSeriesType'' Candle  (DecHist bt)      = return $ DecCand bt
    setSeriesType'' Candle  d@(DecCand _)     = return d
    setSeriesType'' Candle  (DecWhisk bt)     = return $ DecCand bt
    setSeriesType'' Whisker  (DecLine lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecPoint pt)     = do
                                                 let c = getPointColour pt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecLinPt lt _)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecImpulse lt)   = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecStep lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecArea lt)      = do
                                                 let c = fromJust $ getLineColour lt
                                                 bt <- toBar c
                                                 return $ DecWhisk bt
    setSeriesType'' Whisker  (DecBar bt)       = return $ DecWhisk bt
    setSeriesType'' Whisker  (DecHist bt)      = return $ DecWhisk bt
    setSeriesType'' Whisker  (DecCand bt)      = return $ DecWhisk bt
    setSeriesType'' Whisker  d@(DecWhisk _)    = return d

instance SeriesTypes DecoratedSeries where
    setSeriesType'' t (DecSeries o d) = do
                                       d' <- setSeriesType'' t d
                                       return $ DecSeries o d'

setSeriesType' :: Int -> SeriesType -> DataSeries -> Data DataSeries
setSeriesType' i t (DS_Y a)      = do
                                      s' <- setSeriesType'' t $ a A.! i
                                      return $ DS_Y $ a A.// [(i,s')]
setSeriesType' i t (DS_1toN x a) = do
                                      s' <- setSeriesType'' t $ a A.! i
                                      return $ DS_1toN x $ a A.// [(i,s')]
setSeriesType' i t (DS_1to1 a)   = do
                                      let (x,s) = a A.! i
                                      s' <- setSeriesType'' t s
                                      return $ DS_1to1 $ a A.// [(i,(x,s'))]
setSeriesType' _ _ d@(DS_Surf _) = return d

-- | set the series type of a given data series
setSeriesType :: SeriesType -> Int -> Data ()
setSeriesType t i = do
                       ds <- get
                       ds' <- setSeriesType' i t ds
                       put ds'

-- | set the series type of all data series
setAllSeriesTypes :: SeriesType -> Data ()
setAllSeriesTypes t = do
                         ds <- get
                         let ln = dataSeriesNum ds
                         mapM_ (setSeriesType t) [1..ln]

-----------------------------------------------------------------------------

class PlotFormats m where
    modifyFormat :: m () -> DecoratedSeries -> Data DecoratedSeries

instance PlotFormats Line where
    modifyFormat l (DecSeries o (DecLine lt))     = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecLine lt')
    modifyFormat _ d@(DecSeries _ (DecPoint _))   = return d
    modifyFormat l (DecSeries o (DecLinPt lt pt)) = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecLinPt lt' pt)
    modifyFormat l (DecSeries o (DecImpulse lt))  = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecImpulse lt')
    modifyFormat l (DecSeries o (DecStep lt))     = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecStep lt')
    modifyFormat l (DecSeries o (DecArea lt))     = do
                                                    lo <- asks _lineoptions
                                                    let lt' = execLine l lo lt
                                                    return $ DecSeries o (DecArea lt')
    modifyFormat _ d@(DecSeries _ (DecBar _))     = return d
    modifyFormat _ d@(DecSeries _ (DecHist _))    = return d
    modifyFormat _ d@(DecSeries _ (DecCand _))    = return d
    modifyFormat _ d@(DecSeries _ (DecWhisk _))   = return d

instance PlotFormats Point where
    modifyFormat _ d@(DecSeries _ (DecLine _))    = return d
    modifyFormat _ d@(DecSeries _ (DecImpulse _)) = return d
    modifyFormat _ d@(DecSeries _ (DecStep _))    = return d
    modifyFormat _ d@(DecSeries _ (DecArea _))    = return d
    modifyFormat p (DecSeries o (DecPoint pt))    = do
                                                    po <- asks _pointoptions
                                                    let pt' = execPoint p po pt
                                                    return $ DecSeries o (DecPoint pt')
    modifyFormat p (DecSeries o (DecLinPt lt pt)) = do
                                                    po <- asks _pointoptions
                                                    let pt' = execPoint p po pt
                                                    return $ DecSeries o (DecLinPt lt pt')
    modifyFormat _ d@(DecSeries _ (DecBar _))     = return d
    modifyFormat _ d@(DecSeries _ (DecHist _))    = return d
    modifyFormat _ d@(DecSeries _ (DecCand _))    = return d
    modifyFormat _ d@(DecSeries _ (DecWhisk _))   = return d

instance PlotFormats Bar where
    modifyFormat _ d@(DecSeries _ (DecLine _))    = return d
    modifyFormat _ d@(DecSeries _ (DecImpulse _)) = return d
    modifyFormat _ d@(DecSeries _ (DecStep _))    = return d
    modifyFormat _ d@(DecSeries _ (DecArea _))    = return d
    modifyFormat _ d@(DecSeries _ (DecPoint _))   = return d
    modifyFormat _ d@(DecSeries _ (DecLinPt _ _)) = return d
    modifyFormat b   (DecSeries o (DecBar bt))    = do
                                                    bo <- asks _baroptions
                                                    let bt' = execBar b bo bt
                                                    return $ DecSeries o (DecBar bt')
    modifyFormat b   (DecSeries o (DecHist bt))   = do
                                                    bo <- asks _baroptions
                                                    let bt' = execBar b bo bt
                                                    return $ DecSeries o (DecHist bt')
    modifyFormat b   (DecSeries o (DecCand bt))   = do
                                                    bo <- asks _baroptions
                                                    let bt' = execBar b bo bt
                                                    return $ DecSeries o (DecCand bt')
    modifyFormat b   (DecSeries o (DecWhisk bt))  = do
                                                    bo <- asks _baroptions
                                                    let bt' = execBar b bo bt
                                                    return $ DecSeries o (DecWhisk bt')

-- | format the plot elements of a given series
withSeriesFormat :: PlotFormats m => Int -> m () -> Data ()
withSeriesFormat i f = do
                       ds <- get
                       ds' <- case ds of
                                      (DS_Y a)      -> do
                                                       let d = a A.! i
                                                       d' <- modifyFormat f d
                                                       return $ DS_Y $ a A.// [(i,d')]
                                      (DS_1toN x a) -> do
                                                       let d = a A.! i
                                                       d' <- modifyFormat f d
                                                       return $ DS_1toN x $ a A.// [(i,d')]
                                      (DS_1to1 a)   -> do
                                                       let (x,d) = a A.! i
                                                       d' <- modifyFormat f d
                                                       return $ DS_1to1 $ a A.// [(i,(x,d'))]
                                      d@(DS_Surf _) -> return d
                       put ds'

-- | format the plot elements of all series
-- |     the operation to modify the formats is passed the series index
-- |     this allows, for example, colours to be selected from a list
-- |     that gets indexed by the argument
-- | @setColour i = setLineColour $ [black,blue,red,green,yellow] !! i@
withAllSeriesFormats :: PlotFormats m => (Int -> m ()) -> Data ()
withAllSeriesFormats f = do
                         ds <- get
                         let ln = dataSeriesNum ds
                         mapM_ (\i -> withSeriesFormat i (f i)) [1..ln]

-----------------------------------------------------------------------------

class Abscissa a where
    toAbscissa :: a -> Abscissae

toAbscissae :: Abscissa a => [a] -> [Abscissae]
toAbscissae = map toAbscissa

instance Abscissa Series                   where toAbscissa s         = AbsPoints (isMonotoneIncreasing s) s

class Ordinate a where
    toOrdinate :: a -> Ordinates

toOrdinates :: Ordinate a => [a] -> [Ordinates]
toOrdinates = map toOrdinate

instance Ordinate Function                           where toOrdinate f         = OrdFunction Lower (cmap f) Nothing
instance Ordinate VectorFunction                     where toOrdinate f         = OrdFunction Lower f Nothing
instance Ordinate Series                             where toOrdinate s         = OrdPoints Lower (Plain s) Nothing
instance Ordinate (Series,ErrorSeries)               where toOrdinate (s,e)     = OrdPoints Lower (Error s (Left e)) Nothing
instance Ordinate (Series,(ErrorSeries,ErrorSeries)) where toOrdinate (s,(l,u)) = OrdPoints Lower (Error s (Right (l,u))) Nothing
instance Ordinate (MinMaxSeries,(ErrorSeries,ErrorSeries)) where toOrdinate (s,(l,u)) = OrdPoints Lower (MinMax s (Just (l,u))) Nothing
instance Ordinate (Function,AxisSide)                         where toOrdinate (f,ax)       = OrdFunction ax (cmap f) Nothing
instance Ordinate (VectorFunction,AxisSide)                   where toOrdinate (f,ax)       = OrdFunction ax f Nothing
instance Ordinate (Series,AxisSide)                           where toOrdinate (s,ax)       = OrdPoints ax (Plain s) Nothing
instance Ordinate (Series,ErrorSeries,AxisSide)               where toOrdinate (s,e,ax)     = OrdPoints ax (Error s (Left e)) Nothing
instance Ordinate (Series,(ErrorSeries,ErrorSeries),AxisSide) where toOrdinate (s,(l,u),ax) = OrdPoints ax (Error s (Right (l,u))) Nothing
instance Ordinate (MinMaxSeries,(ErrorSeries,ErrorSeries),AxisSide) where toOrdinate (s,(l,u),ax) = OrdPoints ax (MinMax s (Just (l,u))) Nothing
instance Ordinate (Function,SeriesLabel)                         where toOrdinate (f,la)       = OrdFunction Lower (cmap f) (Just la)
instance Ordinate (VectorFunction,SeriesLabel)                   where toOrdinate (f,la)       = OrdFunction Lower f (Just la)
instance Ordinate (Series,SeriesLabel)                           where toOrdinate (s,la)       = OrdPoints Lower (Plain s) (Just la)
instance Ordinate (Series,ErrorSeries,SeriesLabel)               where toOrdinate (s,e,la)     = OrdPoints Lower (Error s (Left e)) (Just la)
instance Ordinate (Series,(ErrorSeries,ErrorSeries),SeriesLabel) where toOrdinate (s,(l,u),la) = OrdPoints Lower (Error s (Right (l,u))) (Just la)

instance Ordinate (Function,AxisSide,SeriesLabel)                          where toOrdinate (f,ax,la)       = OrdFunction ax (cmap f) (Just la)
instance Ordinate (VectorFunction,AxisSide,SeriesLabel)                    where toOrdinate (f,ax,la)       = OrdFunction ax f (Just la)
instance Ordinate (Series,AxisSide,SeriesLabel)                            where toOrdinate (s,ax,la)       = OrdPoints ax (Plain s) (Just la)
instance Ordinate (Series,ErrorSeries,AxisSide,SeriesLabel)                where toOrdinate (s,e,ax,la)     = OrdPoints ax (Error s (Left e)) (Just la)
instance Ordinate (Series,(ErrorSeries,ErrorSeries),AxisSide,SeriesLabel)  where toOrdinate (s,(l,u),ax,la) = OrdPoints ax (Error s (Right (l,u))) (Just la)
instance Ordinate (MinMaxSeries,(ErrorSeries,ErrorSeries),AxisSide,SeriesLabel) where toOrdinate (s,(l,u),ax,la) = OrdPoints ax (MinMax s (Just (l,u))) (Just la)

class Decorations a where
    toDecoration :: a -> Decoration

toDecorations :: Decorations a => [a] -> [Decoration]
toDecorations = map toDecoration

instance Decorations LineType             where toDecoration l     = DecLine l
instance Decorations PointType            where toDecoration p     = DecPoint p
instance Decorations (LineType,PointType) where toDecoration (l,p) = DecLinPt l p
instance Decorations (PointType,LineType) where toDecoration (p,l) = DecLinPt l p
instance Decorations BarType              where toDecoration b     = DecBar b
instance Decorations Decoration           where toDecoration       = id

format :: (Ordinate a, Decorations b) => a -> b -> DecoratedSeries
format o f = DecSeries (toOrdinate o) (toDecoration f)

line :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
line o f = do
           f' <- toLine f
           return $ format o f'

point :: (Ordinate a, PointFormat b) => a -> b -> FormattedSeries
point o f = do
            f' <- toPoint f
            return $ format o f'

linepoint :: (Ordinate a, LineFormat b, PointFormat c) => a -> b -> c -> FormattedSeries
linepoint o l p = do
                  l' <- toLine l
                  p' <- toPoint p
                  return $ format o (l',p')

impulse :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
impulse o f = do
              f' <- toLine f
              setSeriesType'' Impulse (format o f')

step :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
step o f = do
           f' <- toLine f
           setSeriesType'' Step (format o f')

area :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
area o f = do
           f' <- toLine f
           setSeriesType'' Area (format o f')

bar :: (Ordinate a, BarFormat b) => a -> b -> FormattedSeries
bar o f = do
          f' <- toBar f
          return $ format o f'

hist :: (Ordinate a, BarFormat b) => a -> b -> FormattedSeries
hist o f = do
          f' <- toBar f
          setSeriesType'' Hist (format o f')

candle :: (Ordinate a, BarFormat b) => a -> b -> FormattedSeries
candle o f = do
          f' <- toBar f
          setSeriesType'' Candle (format o f')

whisker :: (Ordinate a, BarFormat b) => a -> b -> FormattedSeries
whisker o f = do
          f' <- toBar f
          setSeriesType'' Whisker (format o f')

-----------------------------------------------------------------------------

getType :: SeriesType -> Data Decoration
getType Line = do
               c <- supply
               lt <- toLine (c :: Color)
               return $ toDecoration lt
getType Point = do
                g <- supply
                pt <- toPoint (g :: Glyph)
                return $ toDecoration pt
getType LinePoint = do
                    c <- supply
                    g <- supply
                    lt <- toLine (c :: Color)
                    pt <- toPoint (g :: Glyph)
                    return $ toDecoration (lt,pt)
getType Impulse = do
                  c <- supply
                  lt <- toLine (c :: Color)
                  setSeriesType'' Impulse $ toDecoration lt
getType Step = do
               c <- supply
               lt <- toLine (c :: Color)
               setSeriesType'' Impulse $ toDecoration lt
getType Area = do
               c <- supply
               lt <- toLine (c :: Color)
               setSeriesType'' Area $ toDecoration lt
getType Bar  = do
               c <- supply
               bt <- toBar (c :: Color)
               return $ toDecoration bt
getType Hist = do
               c <- supply
               bt <- toBar (c :: Color)
               setSeriesType'' Hist $ toDecoration bt
getType Candle = do
               c <- supply
               bt <- toBar (c :: Color)
               setSeriesType'' Candle $ toDecoration bt
getType Whisker = do
               c <- supply
               bt <- toBar (c :: Color)
               setSeriesType'' Whisker $ toDecoration bt

getNTypes :: Int -> SeriesType -> Data [Decoration]
getNTypes n st = mapM getType (replicate n st)

-----------------------------------------------------------------------------

class Dataset a where
    toDataSeries :: a -> Data DataSeries

instance Dataset Surface where
    toDataSeries m = return $ DS_Surf m

instance (Ordinate a) => Dataset (SeriesType,[a]) where
    toDataSeries (Line,os) = do
                             let ln = length os
                             cs <- supplyN ln
                             ls <- mapM toLine (cs :: [Color])
                             return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ls
    toDataSeries (Point,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              gs <- supplyN ln
                              ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
                              return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ps
    toDataSeries (LinePoint,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              gs <- supplyN ln
                              ls <- mapM toLine cs
                              ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
                              let ds = toDecorations (zip ls ps)
                              return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Impulse,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              ls <- mapM toLine (cs :: [Color])
                              ds <- mapM (setSeriesType'' Impulse) $ toDecorations ls
                              return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Step,os) = do
                             let ln = length os
                             cs <- supplyN ln
                             ls <- mapM toLine (cs :: [Color])
                             ds <- mapM (setSeriesType'' Step) $ toDecorations ls
                             return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Area,os) = do
                             let ln = length os
                             cs <- supplyN ln
                             ls <- mapM toLine (cs :: [Color])
                             ds <- mapM (setSeriesType'' Area) $ toDecorations ls
                             return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Bar,os) = do
                            let ln = length os
                            cs <- supplyN ln
                            bs <- mapM toBar (cs :: [Color])
                            return $ DS_Y $ A.listArray (1,ln) $ zipWith format os bs
    toDataSeries (Hist,os) = do
                            let ln = length os
                            cs <- supplyN ln
                            bs <- mapM toBar (cs :: [Color])
                            ds <- mapM (setSeriesType'' Hist) $ toDecorations bs
                            return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Candle,os) = do
                            let ln = length os
                            cs <- supplyN ln
                            bs <- mapM toBar (cs :: [Color])
                            ds <- mapM (setSeriesType'' Candle) $ toDecorations bs
                            return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds
    toDataSeries (Whisker,os) = do
                            let ln = length os
                            cs <- supplyN ln
                            bs <- mapM toBar (cs :: [Color])
                            ds <- mapM (setSeriesType'' Whisker) $ toDecorations bs
                            return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds

instance (Abscissa a, Ordinate b) => Dataset (SeriesType,a,[b]) where
    toDataSeries (Line,t,os) = do
                               let ln = length os
                               cs <- supplyN ln
                               ls <- mapM toLine (cs :: [Color])
                               return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                        $ zipWith format os ls
    toDataSeries (Point,t,os) = do
                                let ln = length os
                                cs <- supplyN ln
                                gs <- supplyN ln
                                ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
                                return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                        $ zipWith format os ps
    toDataSeries (LinePoint,t,os) = do
                                let ln = length os
                                cs <- supplyN ln
                                gs <- supplyN ln
                                ls <- mapM toLine cs
                                ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
                                let ds = toDecorations (zip ls ps)
                                return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                        $ zipWith format os ds
    toDataSeries (Impulse,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              ls <- mapM toLine (cs :: [Color])
                              ds <- mapM (setSeriesType'' Impulse) $ toDecorations ls
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Step,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              ls <- mapM toLine (cs :: [Color])
                              ds <- mapM (setSeriesType'' Step) $ toDecorations ls
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Area,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              ls <- mapM toLine (cs :: [Color])
                              ds <- mapM (setSeriesType'' Area) $ toDecorations ls
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Bar,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              bs <- mapM toBar (cs :: [Color])
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os bs
    toDataSeries (Hist,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              bs <- mapM toBar (cs :: [Color])
                              ds <- mapM (setSeriesType'' Hist) $ toDecorations bs
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Candle,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              bs <- mapM toBar (cs :: [Color])
                              ds <- mapM (setSeriesType'' Candle) $ toDecorations bs
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds
    toDataSeries (Whisker,t,os) = do
                              let ln = length os
                              cs <- supplyN ln
                              bs <- mapM toBar (cs :: [Color])
                              ds <- mapM (setSeriesType'' Whisker) $ toDecorations bs
                              return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
                                         $ zipWith format os ds

instance (Abscissa a, Ordinate b) => Dataset [(SeriesType,a,b)] where
    toDataSeries prs = do
                       let ln = length prs
                           (ss,xs,ys) = unzip3 prs
                       ds <- mapM toDataSeries' $ zip ss ys
                       return $ DS_1to1 $ A.listArray (1,ln) $ zip (toAbscissae xs) ds

toDataSeries' :: Ordinate b => (SeriesType,b) -> Data DecoratedSeries
toDataSeries' (Line,o) = do
                         c <- supply
                         l <- toLine (c :: Color)
                         return $ format o l
toDataSeries' (Point,o) = do
                          c <- supply
                          g <- supply
                          p <- toPoint ((g :: Glyph),(c :: Color))
                          return $ format o p
toDataSeries' (LinePoint,o) = do
                          c <- supply
                          g <- supply
                          l <- toLine (c :: Color)
                          p <- toPoint ((g :: Glyph),(c :: Color))
                          let d = toDecoration (l,p)
                          return $ format o d
toDataSeries' (Impulse,o) = do
                         c <- supply
                         l <- toLine (c :: Color)
                         d <- setSeriesType'' Impulse $ toDecoration l
                         return $ format o d
toDataSeries' (Step,o) = do
                         c <- supply
                         l <- toLine (c :: Color)
                         d <- setSeriesType'' Step $ toDecoration l
                         return $ format o d
toDataSeries' (Area,o) = do
                         c <- supply
                         l <- toLine (c :: Color)
                         d <- setSeriesType'' Area $ toDecoration l
                         return $ format o d
toDataSeries' (Bar,o)  = do
                         c <- supply
                         b <- toBar (c :: Color)
                         return $ format o b
toDataSeries' (Hist,o)  = do
                         c <- supply
                         b <- toBar (c :: Color)
                         d <- setSeriesType'' Hist $ toDecoration b
                         return $ format o d
toDataSeries' (Candle,o)  = do
                         c <- supply
                         b <- toBar (c :: Color)
                         d <- setSeriesType'' Candle $ toDecoration b
                         return $ format o d
toDataSeries' (Whisker,o)  = do
                         c <- supply
                         b <- toBar (c :: Color)
                         d <- setSeriesType'' Whisker $ toDecoration b
                         return $ format o d

instance Dataset [FormattedSeries] where
    toDataSeries ds = do
                      let ln = length ds
                      ds' <- sequence ds
                      return $ DS_Y $ A.listArray (1,ln) ds'

instance (Abscissa a) => Dataset (a,[FormattedSeries]) where
    toDataSeries (t,prs) = do
                           let ln = length prs
                           prs' <- sequence prs
                           return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) prs'

instance (Abscissa a) => Dataset [(a,FormattedSeries)] where
    toDataSeries prs = do
                       let ln = length prs
                           (xs,ys) = unzip prs
                       ys' <- sequence ys
                       return $ DS_1to1 $ A.listArray (1,ln) (zip (toAbscissae xs) ys')

-- | set the data set
setDataSeries :: Dataset a => a -> Data ()
setDataSeries d = do
                  ds <- toDataSeries d
                  put ds

-----------------------------------------------------------------------------

monoStep :: Double -> MaybeT (State Double) ()
monoStep d = do
             dp <- get
             when (d < dp) (fail "negative difference")
             put d
{-# INLINE monoStep #-}

isMonotoneIncreasing :: Vector Double -> Bool
isMonotoneIncreasing v = maybe False (\_ -> True) $ evalState (runMaybeT $ (mapVectorM_ monoStep (subVector 1 (size v -1) v))) (v `atIndex` 0)

-----------------------------------------------------------------------------

max_stars_repo_name: JackTheEngineer/plot


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-----------------------------------------------------------------------------
module Linear.Algebra
  ( Algebra(..)
  , Coalgebra(..)
  , multRep, unitalRep
  , comultRep, counitalRep
  ) where

import Control.Lens hiding (index)
import Data.Functor.Rep
import Data.Complex
import Data.Void
import Linear.Vector
import Linear.Quaternion
import Linear.Conjugate
import Linear.V0
import Linear.V1
import Linear.V2
import Linear.V3
import Linear.V4

-- | An associative unital algebra over a ring
class Num r => Algebra r m where
  mult :: (m -> m -> r) -> m -> r
  unital :: r -> m -> r

multRep :: (Representable f, Algebra r (Rep f)) => f (f r) -> f r
multRep ffr = tabulate $ mult (index . index ffr)

unitalRep :: (Representable f, Algebra r (Rep f)) => r -> f r
unitalRep = tabulate . unital

instance Num r => Algebra r Void where
  mult _ _ = 0
  unital _ _ = 0

instance Num r => Algebra r (E V0) where
  mult _ _ = 0
  unital _ _ = 0

instance Num r => Algebra r (E V1) where
  mult f _ = f ex ex
  unital r _ = r

instance Num r => Algebra r () where
  mult f () = f () ()
  unital r () = r

instance (Algebra r a, Algebra r b) => Algebra r (a, b) where
  mult f (a,b) = mult (\a1 a2 -> mult (\b1 b2 -> f (a1,b1) (a2,b2)) b) a
  unital r (a,b) = unital r a * unital r b

instance Num r => Algebra r (E Complex) where
  mult f = \ i -> c^.el i where
   c = (f ee ee - f ei ei) :+ (f ee ei + f ei ee)
  unital r i = (r :+ 0)^.el i

instance (Num r, TrivialConjugate r) => Algebra r (E Quaternion) where
  mult f = index $ Quaternion
    (f ee ee - (f ei ei + f ej ej + f ek ek))
    (V3 (f ee ei + f ei ee + f ej ek - f ek ej)
        (f ee ej + f ej ee + f ek ei - f ei ek)
        (f ee ek + f ek ee + f ei ej - f ej ei))
  unital r = index (Quaternion r 0)

-- | A coassociative counital coalgebra over a ring
class Num r => Coalgebra r m where
  comult :: (m -> r) -> m -> m -> r
  counital :: (m -> r) -> r

comultRep :: (Representable f, Coalgebra r (Rep f)) => f r -> f (f r)
comultRep fr = tabulate $ \i -> tabulate $ \j -> comult (index fr) i j

counitalRep :: (Representable f, Coalgebra r (Rep f)) => f r -> r
counitalRep = counital . index

instance Num r => Coalgebra r Void where
  comult _ _ _ = 0
  counital _ = 0

instance Num r => Coalgebra r () where
  comult f () () = f ()
  counital f = f ()

instance Num r => Coalgebra r (E V0) where
  comult _ _ _ = 0
  counital _ = 0

instance Num r => Coalgebra r (E V1) where
  comult f _ _ = f ex
  counital f = f ex

instance Num r => Coalgebra r (E V2) where
  comult f = index . index v where
    v = V2 (V2 (f ex) 0) (V2 0 (f ey))
  counital f = f ex + f ey

instance Num r => Coalgebra r (E V3) where
  comult f = index . index q where
    q = V3 (V3 (f ex) 0 0)
           (V3 0 (f ey) 0)
           (V3 0 0 (f ez))
  counital f = f ex + f ey + f ez

instance Num r => Coalgebra r (E V4) where
  comult f = index . index v where
    v = V4 (V4 (f ex) 0 0 0) (V4 0 (f ey) 0 0) (V4 0 0 (f ez) 0) (V4 0 0 0 (f ew))
  counital f = f ex + f ey + f ez + f ew

instance Num r => Coalgebra r (E Complex) where
  comult f = \i j -> c^.el i.el j where
    c = (f ee :+ 0) :+ (0 :+ f ei)
  counital f = f ee + f ei

instance (Num r, TrivialConjugate r) => Coalgebra r (E Quaternion) where
  comult f = index . index
    (Quaternion (Quaternion (f ee) (V3 0 0 0))
            (V3 (Quaternion 0 (V3 (f ei) 0 0))
                (Quaternion 0 (V3 0 (f ej) 0))
                (Quaternion 0 (V3 0 0 (f ek)))))
  counital f = f ee + f ei + f ej + f ek

instance (Coalgebra r m, Coalgebra r n) => Coalgebra r (m, n) where
  comult f (a1, b1) (a2, b2) = comult (\a -> comult (\b -> f (a, b)) b1 b2) a1 a2
  counital k = counital $ \a -> counital $ \b -> k (a,b)

ext: hs

max_stars_repo_name: ekmett/linear

max_issues_repo_name: ekmett/linear

max_forks_repo_name: ekmett/linear


text:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Lang.Parser where

import           Import                  hiding ( try )
import           Data.Attoparsec.Combinator
import           Data.Attoparsec.Text
import           Control.Monad.Except           ( MonadError(throwError) )
import           Data.Sequence                  ( fromList )
import           Data.Complex                   ( Complex((:+)) )
import           Data.Ratio                     ( (%) )
import           RIO.Partial                    ( read )

data Base = Bin | Oct | Dec | Hex

oneOf :: [Char] -> Parser Char
oneOf list = satisfy (`elem` list)

noneOf :: [Char] -> Parser Char
noneOf list = satisfy (`notElem` list)

symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

skipSpaces :: Parser ()
skipSpaces = skipMany space

escaped :: Parser Char
escaped = char '\\' *> oneOf "\\\"\'nrt"

parseChar :: Parser LispVal
parseChar = "#\\" *> (name <|> letter <|> symbol <|> oneOf "\\\"\'") <&> Char
  where name = ("space" $> ' ') <|> ("newline" $> '\n')

parseString :: Parser LispVal
parseString =
  char '"' *> many (noneOf "\\\"" <|> escaped) <* char '"' <&> String

parseAtom :: Parser LispVal
parseAtom = do
  firstLetter <- letter <|> symbol
  rest        <- many (letter <|> digit <|> symbol)
  let atom = firstLetter : rest
  return $ case atom of
    "#t" -> Bool True
    "#f" -> Bool False
    _    -> Atom atom

radixPref :: Parser Base
radixPref = char '#' *> (bin <|> oct <|> dec <|> hex)
 where
  bin = char 'b' $> Bin
  oct = char 'o' $> Oct
  dec = char 'd' $> Dec
  hex = char 'x' $> Hex

parseBase :: (Integral a, Read a) => a -> [Char] -> a
parseBase a list = parseBase' list 0
 where
  parseBase' []      n = n
  parseBase' (h : t) n = parseBase' t (n * a + parseDigit h)
  parseDigit c | c == 'A' || c == 'a' = 10
               | c == 'B' || c == 'b' = 11
               | c == 'C' || c == 'c' = 12
               | c == 'D' || c == 'd' = 13
               | c == 'E' || c == 'e' = 14
               | c == 'F' || c == 'f' = 15
               | otherwise            = read [c]

parseInteger :: Parser NumType
parseInteger = Integer <$> do
  pref <- option Dec radixPref
  case pref of
    Bin -> parseBase 2 <$> many1 digit
    Oct -> parseBase 8 <$> many1 digit
    Dec -> parseBase 10 <$> many1 digit
    Hex -> parseBase 16 <$> many1 digit

parseRational :: Parser NumType
parseRational = (%) <$> (decimal <* "/") <*> decimal <&> Rational

parseReal :: Parser NumType
parseReal = double <&> Real

parseComplex :: Parser NumType
parseComplex =
  (:+) <$> (double <* oneOf "+-") <*> (double <* char 'i') <&> Complex

parseNumber :: Parser LispVal
parseNumber =
  try parseInteger
    <|> try parseReal
    <|> try parseRational
    <|> try parseComplex
    <&> Number

parseList :: Parser LispVal -> Parser LispVal
parseList recParser = do
  char '(' *> skipSpaces
  inits <- sepBy recParser skipSpaces
  last  <- skipSpaces *> oneOf ".)"
  case last of
    ')' -> return $ List inits
    _ -> skipSpaces *> recParser <* skipSpaces <* char ')' <&> DottedList inits

parseVector :: Parser LispVal -> Parser LispVal
parseVector recParser =
  "#("
    *>  skipSpaces
    *>  sepBy recParser skipSpaces
    <*  skipSpaces
    <*  char ')'
    <&> Vector
    .   fromList

parseQuotes :: Text -> LispVal -> Parser LispVal -> Parser LispVal
parseQuotes c val recParser = do
  _ <- string c
  x <- recParser
  return $ List [val, x]

parseQuasiquote :: Parser LispVal -> Parser LispVal
parseQuasiquote = parseQuotes "`" (Atom "quasiquote")

parseQuote :: Parser LispVal -> Parser LispVal
parseQuote = parseQuotes "\'" (Atom "quote")

parseUnquote :: Parser LispVal -> Parser LispVal
parseUnquote = parseQuotes "," (Atom "unquote")

parseUnquoteSplicing :: Parser LispVal -> Parser LispVal
parseUnquoteSplicing = parseQuotes ",@" (Atom "unquote-splicing")

parseMetaVal :: Parser LispVal
parseMetaVal = many1 letter <&> MetaVal

parseMetaAtom :: Parser LispVal
parseMetaAtom = "atom:" *> many1 letter <&> MetaAtom

parseMetaList :: Parser LispVal
parseMetaList = "list:" *> many1 letter <&> MetaList

parseMetaVector :: Parser LispVal
parseMetaVector = "vec:" *> many1 letter <&> MetaVector

parseMetaString :: Parser LispVal
parseMetaString = "str:" *> many1 letter <&> MetaString

parseMeta :: Parser LispVal
parseMeta =
  char '@'
    *> (   parseMetaAtom
       <|> parseMetaList
       <|> parseMetaVector
       <|> parseMetaString
       <|> parseMetaVal
       )

parseExpr :: Parser LispVal
parseExpr =
  try parseChar
    <|> try parseString
    <|> try parseNumber
    <|> try (parseList parseExpr)
    <|> try (parseVector parseExpr)
    <|> try (parseQuote parseExpr)
    <|> try (parseQuasiquote parseExpr)
    <|> try (parseUnquoteSplicing parseExpr)
    <|> try (parseUnquote parseExpr)
    <|> try parseAtom

parseExprOrMeta :: Parser LispVal
parseExprOrMeta =
  parseMeta
    <|> try parseChar
    <|> try parseString
    <|> try parseNumber
    <|> try (parseList parseExprOrMeta)
    <|> try (parseVector parseExprOrMeta)
    <|> try (parseQuote parseExprOrMeta)
    <|> try (parseQuasiquote parseExprOrMeta)
    <|> try (parseUnquoteSplicing parseExprOrMeta)
    <|> try (parseUnquote parseExprOrMeta)
    <|> try parseAtom

readOrThrow :: Parser a -> Text -> ThrowsError a
readOrThrow parser input = case parseOnly parser input of
  Left  err -> throwError $ Parser err
  Right val -> return val

readExpr :: Text -> ThrowsError LispVal
readExpr = readOrThrow parseExpr

readExprList :: Text -> ThrowsError [LispVal]
readExprList = readOrThrow (sepBy parseExpr skipSpaces)


text:
{-# language
        ScopedTypeVariables
  #-}

module Main (main) where

import Test.QuickCheck.Classes
import Test.QuickCheck (Arbitrary(..))

import Data.Complex (Complex(..))
import GHC.Fingerprint (Fingerprint(..))
import GHC.Real (Ratio(..))
import Data.Proxy (Proxy(..))

import Data.Primitive.Instances ()

main :: IO ()
main = lawsCheckMany
  [ ("Complex Double", [primLaws (Proxy :: Proxy (Complex Double))])
  , ("Ratio Double", [primLaws (Proxy :: Proxy (Ratio Int))])
  , ("Fingerprint", [primLaws (Proxy :: Proxy Fingerprint)])
  ]

instance Arbitrary Fingerprint where
  arbitrary = Fingerprint <$> arbitrary <*> arbitrary

max_stars_repo_name: nprindle/prim-instances

max_issues_repo_name: nprindle/prim-instances

max_forks_repo_name: nprindle/prim-instances