text:
{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE Rank2Types           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -O0 -freduction-depth=0 #-}
module BlueRipple.Data.CPSVoterPUMS
  (
    cpsVoterPUMSLoader
  , cpsVoterPUMSWithCDLoader
  , CPSVoterPUMS
  , CPSVoterPUMSWeight
  , cpsVoterPUMSRollup
  , cpsVoterPUMSRollupWeightedCounts
  , cpsVoterPUMSElectoralWeights
  , cpsVoterPUMSElectoralWeightsByCD
  , cpsVoterPUMSElectoralWeightsByState
  , cpsVoterPUMSNationalElectoralWeights
  , cpsCountVotersByStateF
--  , cpsKeysToASE
--  , cpsKeysToASR
  , cpsKeysToASER
--  , cpsKeysToASER4
  , cpsKeysToASER5
  , cpsKeysToASER4H
--  , cpsKeysToIdentity
  , cpsPossibleVoter
  , cpsVoted

  ) where

import qualified BlueRipple.Data.CPSVoterPUMS.CPSVoterPUMS_Frame as BR
import qualified BlueRipple.Data.DemographicTypes as BR
import qualified BlueRipple.Data.ElectionTypes as BR
import qualified BlueRipple.Data.DataFrames as BR
import qualified BlueRipple.Data.LoadersCore as BR
import qualified BlueRipple.Data.Loaders as BR
import qualified BlueRipple.Data.Keyed as BR
import qualified BlueRipple.Utilities.KnitUtils as BR
import qualified BlueRipple.Data.CountFolds as BRCF

import qualified Control.Foldl                 as FL
import           Control.Lens                   ((%~))
import qualified Control.Monad.Except          as X
import qualified Control.Monad.State           as ST
import qualified Data.Array                    as A
import qualified Data.Serialize                as S
import qualified Data.Serialize.Text           as S
import qualified Data.List                     as L
import qualified Data.Map                      as M
import           Data.Maybe                     ( fromMaybe, catMaybes)
import qualified Data.Text                     as T
import           Data.Text                      ( Text )
import           Text.Read                      (readMaybe)
import qualified Data.Vinyl                    as V
import           Data.Vinyl.TypeLevel                     (type (++))
import qualified Data.Vinyl.TypeLevel          as V
import qualified Data.Vinyl.Functor            as V
import qualified Frames                        as F
import           Data.Vinyl.Lens               (type (⊆))
import           Frames                         ( (:.)(..) )
import qualified Frames.CSV                    as F
import qualified Frames.InCore                 as FI
import qualified Frames.TH                     as F
import qualified Frames.Melt                   as F
import qualified Text.Read                     as TR

import qualified Frames.Folds                  as FF
import qualified Frames.MapReduce              as FMR
import qualified Frames.ParseableTypes         as FP
import qualified Frames.Transform              as FT
import qualified Frames.MaybeUtils             as FM
import qualified Frames.Utils                  as FU
import qualified Frames.MapReduce              as MR
import qualified Frames.Enumerations           as FE
import qualified Frames.Serialize              as FS
import qualified Frames.SimpleJoins            as FJ
import qualified Frames.Visualization.VegaLite.Data
                                               as FV
--import qualified Graphics.Vega.VegaLite        as GV

{-
import qualified Data.IndexedSet               as IS
import qualified Numeric.GLM.ProblemTypes      as GLM
import qualified Numeric.GLM.ModelTypes      as GLM
import qualified Numeric.GLM.Predict            as GLM
import qualified Numeric.LinearAlgebra         as LA
-}

import           Data.Hashable                  ( Hashable )
import qualified Data.Vector                   as V
--import qualified Data.Vector.Boxed             as VB
import           GHC.Generics                   ( Generic, Rep )

import qualified Knit.Report as K
import qualified Polysemy.Error                as P (mapError, Error)
import qualified Polysemy                as P (raise)

import GHC.TypeLits (Symbol)
import Data.Kind (Type)

cpsVoterPUMSLoader :: (K.KnitEffects r, BR.CacheEffects r)
                   => K.Sem r (K.ActionWithCacheTime r (F.FrameRec CPSVoterPUMS))
cpsVoterPUMSLoader = do
  let cpsPUMSDataPath = BR.LocalData $ T.pack BR.cpsVoterPUMSCSV
  cachedStateAbbrCrosswalk <- BR.stateAbbrCrosswalkLoader
  cachedCPSDataPath <- K.liftKnit $ BR.dataPathWithCacheTime cpsPUMSDataPath
  let cachedDeps = (,) <$> cachedStateAbbrCrosswalk <*> cachedCPSDataPath
  BR.retrieveOrMakeFrame "data/cpsVoterPUMSWithAbbrs.bin" cachedDeps $ \(stateAbbrCrosswalk, dataPath) -> do
    let filter r = (F.rgetField @BR.CPSAGE r >= 18) && (F.rgetField @BR.CPSCITIZEN r /= 5)
    withoutAbbr <- K.ignoreCacheTimeM
                   $ BR.cachedFrameLoader @(F.RecordColumns BR.CPSVoterPUMS_Raw) @CPSVoterPUMS'
                   dataPath
                   Nothing
                   (Just filter)
                   transformCPSVoterPUMSRow
                   Nothing
                   "cpsVoterPUMS.bin"
    fmap (fmap F.rcast) (K.knitMaybe "missing state abbreviation in state abbreviation crosswalk"
                          $ FJ.leftJoinM @'[BR.StateFIPS] withoutAbbr stateAbbrCrosswalk)

-- NB: This should not be used for state-level rollup since some rows will be duplicated if the county is in more than one CD.
cpsVoterPUMSWithCDLoader :: (K.KnitEffects r, BR.CacheEffects r)
                          => K.Sem r (K.ActionWithCacheTime r (F.FrameRec (CPSVoterPUMS V.++ [BR.CongressionalDistrict, BR.CountyWeight])))
cpsVoterPUMSWithCDLoader = do
  cachedCPSVoterPUMS <- cpsVoterPUMSLoader
  cachedCountyToCD <- BR.county2010ToCD116Loader
  let cachedDeps = (,) <$> cachedCPSVoterPUMS <*> cachedCountyToCD
  BR.retrieveOrMakeFrame "data/cpsVoterPUMSWithAbbrsAndCDs.bin" cachedDeps $ \(cpsVoterPUMS, countyToCD) -> do
    K.knitEither . either (Left . show) Right
      $ FJ.leftJoinE
      @[BR.StateFIPS, BR.CountyFIPS]
      (F.filterFrame ((> 0) . F.rgetField @BR.CountyFIPS) cpsVoterPUMS)
      (fmap (F.rcast @[BR.CountyFIPS, BR.StateFIPS, BR.CongressionalDistrict, BR.CountyWeight]) countyToCD)

type CPSVoterPUMSWeight = "CPSVoterPUMSWeight" F.:-> Double

type CPSVoterPUMS = '[ BR.Year
                     , BR.StateFIPS
                     , BR.StateAbbreviation
                     , BR.CountyFIPS
                     , BR.Age4C
                     , BR.SexC
                     , BR.RaceAlone4C
                     , BR.HispC
                     , BR.IsCitizen
                     , BR.CollegeGradC
                     , BR.InCollege
                     , BR.VoteWhyNotC
                     , BR.RegWhyNotC
                     , BR.VoteHowC
                     , BR.VoteWhenC
                     , BR.VotedYNC
                     , BR.RegisteredYNC
                     , CPSVoterPUMSWeight
                     ]

type CPSVoterPUMS' = V.RDelete BR.StateAbbreviation CPSVoterPUMS

cpsVoterPUMSRollup
  :: forall cs rs ks ds.
  ( cs F.⊆ rs
  , ks F.⊆ (ks V.++ cs)
  , cs F.⊆ (ks V.++ cs)
  , FI.RecVec (ks V.++ ds)
  , Ord (F.Record ks)
  )
  => (F.Record rs -> F.Record ks)
  -> FL.Fold (F.Record cs) (F.Record ds)
  -> FL.Fold (F.Record rs) (F.FrameRec (ks V.++ ds))
cpsVoterPUMSRollup getKeys foldData =
  FMR.concatFold
  $ FMR.mapReduceFold
  (FMR.Unpack $ \r -> [getKeys r `V.rappend` F.rcast @cs r])
  (FMR.assignKeysAndData @ks @cs)
  (FMR.foldAndAddKey foldData)

cpsVoterPUMSRollupWithDefault
  ::  forall cs rs ls ks ds.
  ( cs F.⊆ rs
  , (ls V.++ ks) F.⊆ (ls V.++ ks V.++ cs)
  , cs F.⊆ (ls V.++ ks V.++ cs)
  , FI.RecVec (ls V.++ ks V.++ ds)
  , Ord (F.Record (ls V.++ ks))
  , BR.FiniteSet (F.Record ks)
  , (ls V.++ (ks V.++ ds)) ~ ((ls V.++ ks) V.++ ds)
  , Ord (F.Record ls)
  , ls F.⊆ ((ls V.++ ks) V.++ ds)
  , (ks V.++ ds) F.⊆ ((ls V.++ ks) V.++ ds)
  , ks F.⊆ (ks V.++ ds)
  , ds F.⊆ (ks V.++ ds)
  )
  => (F.Record rs -> F.Record ls)
  -> (F.Record rs -> F.Record ks)
  -> FL.Fold (F.Record cs) (F.Record ds)
  -> F.Record ds -- default value if there are no records for a given value of F.Record ks
  -> FL.Fold (F.Record rs) (F.FrameRec (ls V.++ ks V.++ ds))
cpsVoterPUMSRollupWithDefault getLoc getKey foldData defD =
  let addDefaultF = FMR.concatFold
                    $ FMR.mapReduceFold
                    FMR.noUnpack
                    (FMR.assignKeysAndData @ls @(ks V.++ ds))
                    (FMR.makeRecsWithKey id
                     $ FMR.ReduceFold
                     $ const
                     $ BR.addDefaultRec @ks defD
                    )
  in FL.fold addDefaultF <$> cpsVoterPUMSRollup (\r -> getLoc r `V.rappend` getKey r) foldData

cpsVoterPUMSRollupWeightedCounts
  :: forall cs rs ls ks ds.
  ( cs F.⊆ rs
  , (ls V.++ ks) F.⊆ (ls V.++ ks V.++ cs)
  , cs F.⊆ (ls V.++ ks V.++ cs)
  , FI.RecVec (ls V.++ ks V.++ ds)
  , Ord (F.Record (ls V.++ ks))
  , (ls V.++ (ks V.++ ds)) ~ ((ls V.++ ks) V.++ ds)
  , BR.FiniteSet (F.Record ks)
  , Ord (F.Record ls)
  , ls F.⊆ ((ls V.++ ks) V.++ ds)
  , (ks V.++ ds) F.⊆ ((ls V.++ ks) V.++ ds)
  , ks F.⊆ (ks V.++ ds)
  , ds F.⊆ (ks V.++ ds)
  )
  => (F.Record rs -> F.Record ls)
  -> (F.Record rs -> F.Record ks)
  -> (F.Record cs -> Bool) -- which to include
  -> (F.Record cs -> Bool) -- which to count
  -> (F.Record cs -> Double) -- get weight
  -> (Double -> F.Record ds) -- turn the weighted counts into a record
  -> F.Record ds -- default
  -> FL.Fold (F.Record rs) (F.FrameRec (ls V.++ ks V.++ ds))
cpsVoterPUMSRollupWeightedCounts getLoc getKey filterData countIf wgt countToRec defD =
  let countF :: FL.Fold (F.Record cs) (F.Record ds)
      countF =
        let wgtdAllF = FL.premap wgt FL.sum
            wgtdCountF = FL.prefilter countIf $ FL.premap wgt FL.sum
            safeDiv n d = if d > 0 then n/d else 0
            wF = safeDiv <$> wgtdCountF <*> wgtdAllF -- this is acceptable here since (d == 0) iff (n == 0)
        in fmap countToRec wF
      ewFold :: FL.Fold (F.Record cs) (F.Record ds)
      ewFold = FL.prefilter filterData countF
  in cpsVoterPUMSRollupWithDefault getLoc getKey ewFold defD

cpsVoterPUMSElectoralWeights
  :: forall cs rs ls ks.
  ((ls V.++ ks) F.⊆ (ls V.++ ks V.++ cs)
  , cs F.⊆ (ls V.++ ks V.++ cs)
  , cs F.⊆ rs
  , F.ElemOf cs BR.IsCitizen
  , F.ElemOf cs BR.VotedYNC
  , FI.RecVec (ls V.++ ks V.++ BR.EWCols)
  , (ls V.++ (ks V.++ BR.EWCols)) ~ ((ls V.++ ks) V.++ BR.EWCols)
  , Ord (F.Record (ls V.++ ks))
  , Ord (F.Record ls)
  , BR.FiniteSet (F.Record ks)
  , ls F.⊆ ((ls V.++ ks) V.++ BR.EWCols)
  , (ks V.++ BR.EWCols) F.⊆ ((ls V.++ ks) V.++ BR.EWCols)
  , ks F.⊆ (ks V.++ BR.EWCols)
  , BR.EWCols F.⊆ (ks V.++ BR.EWCols)
  )
  => (F.Record rs -> F.Record ls)
  -> (F.Record rs -> F.Record ks)
  -> (F.Record cs -> Double)
  -> FL.Fold (F.Record rs) (F.FrameRec (ls V.++ ks V.++ BR.EWCols))
cpsVoterPUMSElectoralWeights getLoc getKey getWgt =
  let toRec :: Double -> F.Record BR.EWCols
      toRec w =  BR.EW_Census F.&: BR.EW_Citizen F.&: w F.&: V.RNil
      citizen r = F.rgetField @BR.IsCitizen r
      possibleVoter r = cpsPossibleVoter $ F.rgetField @BR.VotedYNC r
      voted r = cpsVoted $ F.rgetField @BR.VotedYNC r
  in cpsVoterPUMSRollupWeightedCounts @cs
     getLoc
     getKey
     (\r -> citizen r &&  possibleVoter r)
     voted
     getWgt
     toRec
     (toRec 0) -- this is a reasonable default to use for inference but not great to use this data directly

cpsVoterPUMSElectoralWeightsByState
  :: forall ks.
  (F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight]) CPSVoterPUMSWeight
  , F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight]) BR.IsCitizen
  , F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight]) BR.VotedYNC
  , FI.RecVec (ks ++ BR.EWCols)
  , Ord (F.Record ks)
  , ks F.⊆ ('[BR.Year, BR.StateAbbreviation, BR.StateFIPS] V.++ ks V.++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight])
  , BR.FiniteSet (F.Record ks)
  , F.ElemOf (ks V.++ BR.EWCols) BR.ElectoralWeight
  , F.ElemOf (ks V.++ BR.EWCols) BR.ElectoralWeightOf
  , F.ElemOf (ks V.++ BR.EWCols) BR.ElectoralWeightSource
  , (ks V.++ BR.EWCols) F.⊆ ('[BR.Year, BR.StateAbbreviation, BR.StateFIPS] V.++ ks V.++ BR.EWCols)
  , ks F.⊆ (ks V.++ BR.EWCols)
  )
  => (F.Record CPSVoterPUMS -> F.Record ks)
  -> FL.Fold (F.Record CPSVoterPUMS) (F.FrameRec ('[BR.Year, BR.StateAbbreviation, BR.StateFIPS] V.++ ks V.++ BR.EWCols))
cpsVoterPUMSElectoralWeightsByState getCatKey =
  cpsVoterPUMSElectoralWeights @[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight]
  (F.rcast @[BR.Year, BR.StateAbbreviation, BR.StateFIPS]) getCatKey (F.rgetField @CPSVoterPUMSWeight)

cpsVoterPUMSNationalElectoralWeights
  :: forall ks.
  (F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight]) CPSVoterPUMSWeight
  , F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight]) BR.IsCitizen
  , F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight]) BR.VotedYNC
  , FI.RecVec (ks ++ BR.EWCols)
  , Ord (F.Record ks)
  , ks F.⊆ ('[BR.Year] V.++ ks V.++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight])
  , BR.FiniteSet (F.Record ks)
  , F.ElemOf (ks V.++ BR.EWCols) BR.ElectoralWeight
  , F.ElemOf (ks V.++ BR.EWCols) BR.ElectoralWeightOf
  , F.ElemOf (ks V.++ BR.EWCols) BR.ElectoralWeightSource
  , (ks V.++ BR.EWCols) F.⊆ ('[BR.Year] V.++ ks V.++ BR.EWCols)
  , ks F.⊆ (ks V.++ BR.EWCols)
  )
  => (F.Record CPSVoterPUMS -> F.Record ks)
  -> FL.Fold (F.Record CPSVoterPUMS) (F.FrameRec ('[BR.Year] V.++ ks V.++ BR.EWCols))
cpsVoterPUMSNationalElectoralWeights getCatKey =
  cpsVoterPUMSElectoralWeights @[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight] (F.rcast @'[BR.Year]) getCatKey (F.rgetField @CPSVoterPUMSWeight)

cpsVoterPUMSElectoralWeightsByCD
  :: forall ks.
  (F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight, BR.CountyWeight]) CPSVoterPUMSWeight
  , F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight, BR.CountyWeight]) BR.CountyWeight
  , F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight, BR.CountyWeight]) BR.IsCitizen
  , F.ElemOf (ks ++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight, BR.CountyWeight]) BR.VotedYNC
  , FI.RecVec (ks ++ BR.EWCols)
  , Ord (F.Record ks)
  , ks F.⊆ ('[BR.Year, BR.StateAbbreviation, BR.StateFIPS, BR.CongressionalDistrict]
             V.++ ks
             V.++ '[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight, BR.CountyWeight])
  , BR.FiniteSet (F.Record ks)
  , F.ElemOf (ks V.++ BR.EWCols) BR.ElectoralWeight
  , F.ElemOf (ks V.++ BR.EWCols) BR.ElectoralWeightOf
  , F.ElemOf (ks V.++ BR.EWCols) BR.ElectoralWeightSource
  , (ks V.++ BR.EWCols) F.⊆ ('[BR.Year, BR.StateAbbreviation, BR.StateFIPS, BR.CongressionalDistrict] V.++ ks V.++ BR.EWCols)
  , ks F.⊆ (ks V.++ BR.EWCols)
  )
  => (F.Record (CPSVoterPUMS V.++ [BR.CongressionalDistrict, BR.CountyWeight]) -> F.Record ks)
  -> FL.Fold (F.Record (CPSVoterPUMS V.++ [BR.CongressionalDistrict, BR.CountyWeight]))
  (F.FrameRec ('[BR.Year, BR.StateAbbreviation, BR.StateFIPS, BR.CongressionalDistrict] V.++ ks V.++ BR.EWCols))
cpsVoterPUMSElectoralWeightsByCD getCatKey =
  let wgt r = F.rgetField @CPSVoterPUMSWeight r * F.rgetField @BR.CountyWeight r
  in cpsVoterPUMSElectoralWeights @[BR.IsCitizen, BR.VotedYNC, CPSVoterPUMSWeight, BR.CountyWeight]
     (F.rcast @[BR.Year, BR.StateAbbreviation, BR.StateFIPS, BR.CongressionalDistrict]) getCatKey wgt

-- rollup for MRP
cpsCountVotersByStateF
  :: forall ks.
  (Ord (F.Record ks)
  , FI.RecVec (ks V.++ BRCF.CountCols)
  , ks F.⊆ CPSVoterPUMS
  )
  => (F.Record CPSVoterPUMS -> F.Record ks)
  -> Int -- year
  -> FMR.Fold
  (F.Record CPSVoterPUMS)
  (F.FrameRec ('[BR.StateAbbreviation] V.++ ks V.++ BRCF.CountCols))
cpsCountVotersByStateF getCatKey year =
  let isYear y r = F.rgetField @BR.Year r == y
      possible r = cpsPossibleVoter $ F.rgetField @BR.VotedYNC r
      citizen r = F.rgetField @BR.IsCitizen r
      includeRow r = isYear year r &&  possible r && citizen r
      voted r = cpsVoted $ F.rgetField @BR.VotedYNC r
  in BRCF.weightedCountFold
     (F.rcast @(BR.StateAbbreviation ': ks))
     (F.rcast @[BR.VotedYNC, CPSVoterPUMSWeight])
     includeRow
     voted
     (F.rgetField @CPSVoterPUMSWeight)

cpsCountVotersByCDF
  :: forall ks.
  (Ord (F.Record ks)
  , FI.RecVec (ks V.++ BRCF.CountCols)
  , ks F.⊆ (CPSVoterPUMS V.++ [BR.CongressionalDistrict, BR.CountyWeight])
  )
  => (F.Record (CPSVoterPUMS V.++ [BR.CongressionalDistrict, BR.CountyWeight]) -> F.Record ks)
  -> Int -- year
  -> FMR.Fold
  (F.Record (CPSVoterPUMS V.++ [BR.CongressionalDistrict, BR.CountyWeight]))
  (F.FrameRec ('[BR.StateAbbreviation, BR.CongressionalDistrict] V.++ ks V.++ BRCF.CountCols))
cpsCountVotersByCDF getCatKey year =
  let isYear y r = F.rgetField @BR.Year r == y
      possible r = cpsPossibleVoter $ F.rgetField @BR.VotedYNC r
      citizen r = F.rgetField @BR.IsCitizen r
      includeRow r = isYear year r &&  possible r && citizen r
      voted r = cpsVoted $ F.rgetField @BR.VotedYNC r
      wgt r = F.rgetField @CPSVoterPUMSWeight r * F.rgetField @BR.CountyWeight r
  in BRCF.weightedCountFold
     (F.rcast @([BR.StateAbbreviation, BR.CongressionalDistrict] V.++ ks))
     (F.rcast  @[BR.VotedYNC, CPSVoterPUMSWeight, BR.CountyWeight])
     includeRow
     voted
     wgt

-- We give the option of counting "In College" as "College Grad". This is different from what the census summary tables do.
-- NB: This needs to be done consistently with the demographics.
-- We don't have this information for the preferences, at least not from CCES, so doing this amounts to assigning
-- "in college" people to either Grad or NonGrad buckets in terms of voting pref.

cpsKeysToASER5 :: Bool
               -> F.Record '[BR.Age4C, BR.SexC, BR.CollegeGradC, BR.InCollege, BR.RaceAlone4C, BR.HispC]
               -> F.Record BR.CatColsASER5
cpsKeysToASER5 addInCollegeToGrads r =
  let cg = F.rgetField @BR.CollegeGradC r
      ic = addInCollegeToGrads && F.rgetField @BR.InCollege r
      ra4 =  F.rgetField @BR.RaceAlone4C r
      h = F.rgetField @BR.HispC r
  in (BR.age4ToSimple $ F.rgetField @BR.Age4C r)
     F.&: (F.rgetField @BR.SexC r)
     F.&: (if cg == BR.Grad || ic then BR.Grad else BR.NonGrad)
     F.&: BR.race5FromRaceAlone4AndHisp True ra4 h
     F.&: V.RNil

cpsKeysToASER4H :: Bool
                -> F.Record [BR.Age4C, BR.SexC, BR.CollegeGradC, BR.InCollege, BR.RaceAlone4C, BR.HispC]
                -> F.Record [BR.SimpleAgeC, BR.SexC, BR.CollegeGradC, BR.RaceAlone4C, BR.HispC]
cpsKeysToASER4H addInCollegeToGrads r =
  let cg = F.rgetField @BR.CollegeGradC r
      ic = addInCollegeToGrads && F.rgetField @BR.InCollege r
  in (BR.age4ToSimple $ F.rgetField @BR.Age4C r)
     F.&: (F.rgetField @BR.SexC r)
     F.&: (if cg == BR.Grad || ic then BR.Grad else BR.NonGrad)
     F.&: F.rgetField @BR.RaceAlone4C r
     F.&: F.rgetField @BR.HispC r
     F.&: V.RNil

cpsKeysToASER :: Bool -> F.Record '[BR.Age4C, BR.SexC, BR.CollegeGradC, BR.InCollege, BR.RaceAlone4C, BR.HispC] -> F.Record BR.CatColsASER
cpsKeysToASER addInCollegeToGrads r =
  let cg = F.rgetField @BR.CollegeGradC r
      ic = addInCollegeToGrads && F.rgetField @BR.InCollege r
      ra4 =  F.rgetField @BR.RaceAlone4C r
      h = F.rgetField @BR.HispC r
  in (BR.age4ToSimple $ F.rgetField @BR.Age4C r)
     F.&: (F.rgetField @BR.SexC r)
     F.&: (if cg == BR.Grad || ic then BR.Grad else BR.NonGrad)
     F.&: (BR.simpleRaceFromRaceAlone4AndHisp True ra4 h)
     F.&: V.RNil

{-
cpsKeysToASER4 :: Bool -> F.Record '[BR.Age4C, BR.SexC, BR.CollegeGradC, BR.InCollege, BR.Race5C] -> F.Record BR.CatColsASER4
cpsKeysToASER4 addInCollegeToGrads r =
  let cg = F.rgetField @BR.CollegeGradC r
      ic = addInCollegeToGrads && F.rgetField @BR.InCollege r
  in (BR.age4ToSimple $ F.rgetField @BR.Age4C r)
     F.&: (F.rgetField @BR.SexC r)
     F.&: (if cg == BR.Grad || ic then BR.Grad else BR.NonGrad)
     F.&: (BR.race4FromRace5 $ F.rgetField @BR.Race5C r)
     F.&: V.RNil

cpsKeysToASER :: Bool -> F.Record '[BR.Age4C, BR.SexC, BR.CollegeGradC, BR.InCollege, BR.Race5C] -> F.Record BR.CatColsASER
cpsKeysToASER addInCollegeToGrads r =
  let cg = F.rgetField @BR.CollegeGradC r
      ic = addInCollegeToGrads && F.rgetField @BR.InCollege r
  in (BR.age4ToSimple $ F.rgetField @BR.Age4C r)
     F.&: (F.rgetField @BR.SexC r)
     F.&: (if cg == BR.Grad || ic then BR.Grad else BR.NonGrad)
     F.&: (BR.simpleRaceFromRace5 $ F.rgetField @BR.Race5C r)
     F.&: V.RNil

cpsKeysToASE :: Bool -> F.Record '[BR.Age4C, BR.SexC, BR.CollegeGradC, BR.InCollege, BR.Race5C] -> F.Record BR.CatColsASE
cpsKeysToASE addInCollegeToGrads r =
  let cg = F.rgetField @BR.CollegeGradC r
      ic = addInCollegeToGrads && F.rgetField @BR.InCollege r
  in (BR.age4ToSimple $ F.rgetField @BR.Age4C r)
     F.&: (F.rgetField @BR.SexC r)
     F.&: (if cg == BR.Grad || ic then BR.Grad else BR.NonGrad)
     F.&: V.RNil

cpsKeysToASR :: F.Record '[BR.Age4C, BR.SexC, BR.CollegeGradC, BR.InCollege, BR.Race5C] -> F.Record BR.CatColsASR
cpsKeysToASR r =
  (BR.age4ToSimple $ F.rgetField @BR.Age4C r)
  F.&: (F.rgetField @BR.SexC r)
  F.&: (BR.simpleRaceFromRace5 $ F.rgetField @BR.Race5C r)
  F.&: V.RNil

cpsKeysToIdentity :: F.Record '[BR.Age4C, BR.SexC, BR.CollegeGradC, BR.InCollege, BR.Race5C] -> F.Record '[]
cpsKeysToIdentity = const V.RNil
-}
-- we have to drop all records with age < 18
intToAge4 :: Int -> BR.Age4
intToAge4 n
  | n < 18 = error "CPS Voter record with age < 18"
  | n < 24 = BR.A4_18To24
  | n < 45 = BR.A4_25To44
  | n < 65 = BR.A4_45To64
  | otherwise = BR.A4_65AndOver

intToCollegeGrad :: Int -> BR.CollegeGrad
intToCollegeGrad n = if n < 111 then BR.NonGrad else BR.Grad

intToInCollege :: Int -> Bool
intToInCollege n = n == 4

intToSex :: Int -> BR.Sex
intToSex n = if n == 1 then BR.Male else BR.Female

intToRaceAlone4 :: Int -> BR.RaceAlone4
intToRaceAlone4 rN
  | rN == 100 = BR.RA4_White
  | rN == 200 = BR.RA4_Black
  | rN == 651 = BR.RA4_Asian
  | otherwise = BR.RA4_Other

intToHisp :: Int -> BR.Hisp
intToHisp hN
  | (hN >= 100) && (hN <= 901) = BR.Hispanic
  | otherwise = BR.NonHispanic

intsToRace5 :: Int -> Int -> BR.Race5
intsToRace5 hN rN
  | (hN >= 100) && (hN <= 901) = BR.R5_Hispanic
  | rN == 100 = BR.R5_WhiteNonHispanic
  | rN == 200 = BR.R5_Black
  | rN == 651 = BR.R5_Asian
  | otherwise = BR.R5_Other

intToIsCitizen :: Int -> Bool
intToIsCitizen n = n /= 5

intToVoteWhyNot :: Int -> BR.VoteWhyNot
intToVoteWhyNot n
  | n == 1 = BR.VWN_PhysicallyUnable
  | n == 2 = BR.VWN_Away
  | n == 3 = BR.VWN_Forgot
  | n == 4 = BR.VWN_NotInterested
  | n == 5 = BR.VWN_Busy
  | n == 6 = BR.VWN_Transport
  | n == 7 = BR.VWN_DislikeChoices
  | n == 8 = BR.VWN_RegIssue
  | n == 9 = BR.VWN_Weather
  | n == 10 = BR.VWN_BadPollingPlace
  | otherwise = BR.VWN_Other

intToRegWhyNot :: Int -> BR.RegWhyNot
intToRegWhyNot n
  | n == 1 = BR.RWN_MissedDeadline
  | n == 2 = BR.RWN_DidntKnowHow
  | n == 3 = BR.RWN_Residency
  | n == 4 = BR.RWN_PhysicallyUnable
  | n == 5 = BR.RWN_Language
  | n == 6 = BR.RWN_NotInterested
  | n == 7 = BR.RWN_MyVoteIrrelevant
  | otherwise = BR.RWN_Other

intToVoteHow :: Int -> BR.VoteHow
intToVoteHow n
  | n == 1 = BR.VH_InPerson
  | n == 2 = BR.VH_ByMail
  | otherwise = BR.VH_Other

intToVoteWhen :: Int -> BR.VoteWhen
intToVoteWhen n
  | n == 1 = BR.VW_ElectionDay
  | n == 2 = BR.VW_BeforeElectionDay
  | otherwise = BR.VW_Other

intToVotedYN :: Int -> BR.VotedYN
intToVotedYN n
  | n == 1 = BR.VYN_DidNotVote
  | n == 2 = BR.VYN_Voted
  | n == 96 = BR.VYN_Refused
  | n == 97 = BR.VYN_DontKnow
  | n == 98 = BR.VYN_NoResponse
  | otherwise = BR.VYN_NotInUniverse

cpsPossibleVoter :: BR.VotedYN -> Bool
cpsPossibleVoter BR.VYN_DidNotVote = True
cpsPossibleVoter BR.VYN_Voted = True
cpsPossibleVoter BR.VYN_Refused = False
cpsPossibleVoter BR.VYN_DontKnow = False
cpsPossibleVoter BR.VYN_NoResponse = False
cpsPossibleVoter BR.VYN_NotInUniverse = False

cpsVoted :: BR.VotedYN -> Bool
cpsVoted BR.VYN_Voted = True
cpsVoted _ = False

intToRegisteredYN :: Int -> BR.RegisteredYN
intToRegisteredYN n
  | n == 1 = BR.RYN_NotRegistered
  | n == 2 = BR.RYN_Registered
  | otherwise = BR.RYN_Other

transformCPSVoterPUMSRow :: BR.CPSVoterPUMS_Raw -> F.Record CPSVoterPUMS'
transformCPSVoterPUMSRow = F.rcast . addCols  where
  addCols = (FT.addOneFromOne @BR.CPSRACE @BR.RaceAlone4C intToRaceAlone4)
            . (FT.addOneFromOne @BR.CPSHISPAN @BR.HispC intToHisp)
            . (FT.addName @BR.CPSVOSUPPWT @CPSVoterPUMSWeight)
            . (FT.addName @BR.CPSCOUNTY @BR.CountyFIPS)
            . (FT.addName @BR.CPSSTATEFIP @BR.StateFIPS)
            . (FT.addName @BR.CPSYEAR @BR.Year)
            . (FT.addOneFromOne @BR.CPSVOREG @BR.RegisteredYNC intToRegisteredYN)
            . (FT.addOneFromOne @BR.CPSVOTED @BR.VotedYNC intToVotedYN)
            . (FT.addOneFromOne @BR.CPSVOTEWHEN @BR.VoteWhenC intToVoteWhen)
            . (FT.addOneFromOne @BR.CPSVOTEHOW @BR.VoteHowC intToVoteHow)
            . (FT.addOneFromOne @BR.CPSVOYNOTREG @BR.RegWhyNotC intToRegWhyNot)
            . (FT.addOneFromOne @BR.CPSVOWHYNOT @BR.VoteWhyNotC intToVoteWhyNot)
            . (FT.addOneFromOne @BR.CPSSCHLCOLL @BR.InCollege intToInCollege)
            . (FT.addOneFromOne @BR.CPSEDUC @BR.CollegeGradC intToCollegeGrad)
            . (FT.addOneFromOne @BR.CPSCITIZEN @BR.IsCitizen intToIsCitizen)
            . (FT.addOneFromOne @BR.CPSSEX @BR.SexC intToSex)
            . (FT.addOneFromOne @BR.CPSAGE @BR.Age4C intToAge4)

{-
transformCPSVoterPUMSRow :: BR.CPSVoterPUMS_Raw -> F.Record CPSVoterPUMS'
transformCPSVoterPUMSRow r = F.rcast @CPSVoterPUMS' (mutate r) where
  addAge = FT.recordSingleton @BR.Age4C . intToAge4 . F.rgetField @BR.CPSAGE
  addSex =  FT.recordSingleton @BR.SexC . intToSex . F.rgetField @BR.CPSSEX
  hN = F.rgetField @BR.CPSHISPAN
  rN = F.rgetField @BR.CPSRACE
  addRace r = FT.recordSingleton @BR.Race5C $ intsToRace5 (hN r) (rN r)
  addIsCitizen = FT.recordSingleton @BR.IsCitizen . intToIsCitizen . F.rgetField @BR.CPSCITIZEN
  addCollegeGrad = FT.recordSingleton @BR.CollegeGradC . intToCollegeGrad . F.rgetField @BR.CPSEDUC
  addInCollege = FT.recordSingleton @BR.InCollege . intToInCollege . F.rgetField @BR.CPSSCHLCOLL
  addVoteWhyNot = FT.recordSingleton @BR.VoteWhyNotC . intToVoteWhyNot . F.rgetField @BR.CPSVOWHYNOT
  addRegWhyNot = FT.recordSingleton @BR.RegWhyNotC . intToRegWhyNot . F.rgetField @BR.CPSVOYNOTREG
  addVoteHow = FT.recordSingleton @BR.VoteHowC . intToVoteHow . F.rgetField @BR.CPSVOTEHOW
  addVoteWhen = FT.recordSingleton @BR.VoteWhenC . intToVoteWhen . F.rgetField @BR.CPSVOTEWHEN
  addVotedYN = FT.recordSingleton @BR.VotedYNC . intToVotedYN . F.rgetField @BR.CPSVOTED
  addRegisteredYN = FT.recordSingleton @BR.RegisteredYNC . intToRegisteredYN . F.rgetField @BR.CPSVOREG
  mutate = FT.retypeColumn @BR.CPSYEAR @BR.Year
           . FT.retypeColumn @BR.CPSSTATEFIP @BR.StateFIPS
           . FT.retypeColumn @BR.CPSCOUNTY @BR.CountyFIPS
           . FT.mutate addAge
           . FT.mutate addSex
           . FT.mutate addRace
           . FT.mutate addIsCitizen
           . FT.mutate addCollegeGrad
           . FT.mutate addInCollege
           . FT.mutate addVoteWhyNot
           . FT.mutate addRegWhyNot
           . FT.mutate addVoteHow
           . FT.mutate addVoteWhen
           . FT.mutate addVotedYN
           . FT.mutate addRegisteredYN
           . FT.retypeColumn @BR.CPSVOSUPPWT @CPSVoterPUMSWeight
-}

-- to use in maybeRecsToFrame
-- if SCHG indicates not in school we map to 0 so we will interpret as "Not In College"
{-
fixPUMSRow :: F.Rec (Maybe F.:. F.ElField) PUMS_Raw -> F.Rec (Maybe F.:. F.ElField) PUMS_Raw
fixPUMSRow r = (F.rsubset %~ missingInCollegeTo0)
               $ r where
  missingInCollegeTo0 :: F.Rec (Maybe :. F.ElField) '[BR.PUMSSCHG] -> F.Rec (Maybe :. F.ElField) '[BR.PUMSSCHG]
  missingInCollegeTo0 = FM.fromMaybeMono 0
-}

max_stars_repo_name: blueripple/preference-model

max_issues_repo_name: blueripple/preference-model

max_forks_repo_name: blueripple/preference-model


text:
import Test.Tasty
import Test.Tasty.HUnit

import Control.Lens
import Control.Monad

import qualified Data.ByteString as B
import Data.Default
import Data.Function
import Data.List
import Data.Ord
import Data.Maybe

import Linear

import Linear.Vector
import qualified Numeric.LinearAlgebra.HMatrix as HM
import qualified FrameGrabber
import StartFiducial as SF
import StartFiducialDebug
import TileMatcher
import TrackTracker as TT
import qualified TileMatcherDebug
import qualified Loop
import qualified Track
import Transform
import qualified OpenCV as CV
import TrackDebug
import OpenCV.Core.Types.Mat
import OpenCV.VideoIO.Types
import qualified Data.Vector as V

import Image
import qualified Video
import MaskDebug
import qualified SegmentPositionerTests
import FrameWriter

import Text.Printf

import System.IO.Unsafe ( unsafePerformIO )

main :: IO ()
main = defaultMain unitTests

unitTests = testGroup "Unit tests"
  [ Video.tests
  , SegmentPositionerTests.tests
  , startFiducialTests
  , tileMatcherTests
  , trackDebugTests
  , loopTests
  , trackTests
  , trackTrackingTests
  ]

startFiducialTests :: TestTree
startFiducialTests = testGroup "Start fiducial tests"
  [ testCase "Start fiducial position" testStartFiducialPosition
  , testCase "Start fiducial transform" testStartFiducialTransform
  , testCase "Start fiducial consistency" testStartFiducialConsistency
  , testStartFiducialIsRectangle
  ]

testStartFiducialPosition :: Assertion
testStartFiducialPosition = do
  points@(V2 center tip) <- fromJust <$> SF.findCenter idleNoCars
  renderImage "/tmp/drawCenter.png" $ drawArrow idleNoCars points

  (round <$> center) @?= V2 485 151
  (round <$> tip) @?= V2 383 430

testStartFiducialTransform :: Assertion
testStartFiducialTransform = do
  points <- fromJust <$> SF.findCenter idleNoCars
  roundTransform (transformFromVector points) @?= Track.transform idleNoCarsStart

video :: FilePath
video = "test/video/idle-no-cars-0-3-frames.mp4"

testStartFiducialConsistency :: Assertion
testStartFiducialConsistency = do
  (frames :: [FrameGrabber.TestMat]) <- FrameGrabber.getFrames video
  (points :: [Maybe (V2 (V2 Double))]) <- mapM SF.findCenter frames

  let (debugs :: [SF.FrameMat]) = zipWith drawArrow frames (map fromJust points)

  let renderFrame n = renderImage ("/tmp/testStartFiducial_" ++ show n ++ ".png")
  zipWithM_ renderFrame [0..] debugs

  let centers = fmap (^._x) (catMaybes points)
  let mean = sumV centers ^/ 3
  let deltas = fmap (mean ^-^) centers
  (< V2 1.0 1.0) <$> deltas @?= replicate 3 True

testStartFiducialIsRectangle :: TestTree
testStartFiducialIsRectangle = testGroup "isRectangle"
  [ testCase "perfect" $ isIt True [V2 5 0, V2 5 10, V2 0 10, V2 0 0]
  , testCase "close" $ isIt True [V2 4 0, V2 5 10, V2 0 13, V2 0 0]
  , testCase "way off" $ isIt False [V2 2 0, V2 5 10, V2 0 12, V2 0 0]
  ]
  where isIt b = (@?= b) . SF.isRectangle . V.fromList

tileMatcherTests :: TestTree
tileMatcherTests = testGroup "Tile matcher tests"
  [ testCase "Straight is a straight" tileMatcherStraight
  , testCase "Left is a left" tileMatcherLeft
  , testCase "Find track" tileMatcherFindTrack
  ]

tileMatcherStraight :: Assertion
tileMatcherStraight = do
  let straight = idleNoCarsTrack Loop.!! 1
  renderImage "/tmp/tileMatcherStraight.png" $ TileMatcherDebug.drawTileMasks idleNoCars straight

tileMatcherLeft :: Assertion
tileMatcherLeft = do
  let left = idleNoCarsTrack Loop.!! 2
  renderImage "/tmp/tileMatcherLeft.png" $ TileMatcherDebug.drawTileMasks idleNoCars left

tileMatcherFindTrack :: Assertion
tileMatcherFindTrack = do
  let foundTrack = TileMatcher.findTrack idleNoCars idleNoCarsStart
  renderImage "/tmp/tileMatcherTrackMask.png" $ drawTrackMask idleNoCars foundTrack
  foundTrack @?= idleNoCarsTrack

trackDebugTests :: TestTree
trackDebugTests = testGroup "TrackDebug tests"
  [ testCase "drawTrack" trackDebugArrows
  , testCase "outline" trackDebugOutline
  , testCase "Draw track mask" trackDrawTrackMask
  ]

trackDebugArrows :: Assertion
trackDebugArrows = renderImage "/tmp/trackArrows.png" $ drawTrackArrows idleNoCars idleNoCarsTrack

trackDebugOutline :: Assertion
trackDebugOutline = renderImage "/tmp/trackOutline.png" $ drawTrackOutline idleNoCars idleNoCarsTrack

trackDrawTrackMask :: Assertion
trackDrawTrackMask =  renderImage "/tmp/trackMask.png" $ drawTrackMask idleNoCars idleNoCarsTrack

loopTests :: TestTree
loopTests = testGroup "Loop tests"
  [ testCase "mkLoop single" mkLoopSingleTest
  , testCase "mkLoop multiple" mkLoopMultipleTest
  , testCase "mkLoop multiple second" mkLoopMultipleSecondTest
  , testCase "mkLoop multiple last" mkLoopMultipleLastTest
  , testCase "loop unfold" loopUnfold
  , testCase "loop unfold from middle" loopUnfoldMiddle
  ]

mkLoopSingleTest :: Assertion
mkLoopSingleTest = let
  loop = Loop.mkLoop [1]
  Loop.Loop end (Loop.Start one) next = loop
  in one @?= 1

mkLoopMultipleTest :: Assertion
mkLoopMultipleTest = let
  loop = Loop.mkLoop [1,2,3]
  Loop.Loop end (Loop.Start one) next = loop
  Loop.Loop _ (Loop.Node two) _ = next
  Loop.Loop _ (Loop.Node three) _ = end
  in [one, two, three] @?= [1,2,3]

mkLoopMultipleSecondTest :: Assertion
mkLoopMultipleSecondTest = let
  loop = Loop.mkLoop [1,2,3]
  Loop.Loop _ _ (Loop.Loop left x right) = loop
  Loop.Loop _ (Loop.Start one) _ = left
  Loop.Node two = x
  Loop.Loop _ (Loop.Node three) _ = right
  in [one, two, three] @?= [1,2,3]

mkLoopMultipleLastTest :: Assertion
mkLoopMultipleLastTest = let
  loop = Loop.mkLoop [1,2,3]
  Loop.Loop (Loop.Loop left x right) _ _ = loop
  Loop.Loop _ (Loop.Node two) _ = left
  Loop.Node three = x
  Loop.Loop _ (Loop.Start one) _ = right
  in [two, three, one] @?= [2,3, 1]

loopUnfold :: Assertion
loopUnfold = let
  list = [1, 2]
  loop = Loop.mkLoop list
  in Loop.unfold loop @?= list

loopUnfoldMiddle :: Assertion
loopUnfoldMiddle = let
  list = [1..6]
  loop = Loop.mkLoop list
  Loop.Loop _ _ second = loop
  in Loop.unfold second @?= list

trackTests :: TestTree
trackTests = testGroup "Track tests"
  [testCase "parseTrack" parseTestTrack
  , testCase "parseBadTrack" parseBadTrack
  , testCase "start" trackStart
  , testCase "nextSegment" trackNextSegment
  , testCase "parse to length" trackLength
  , testCase "scanl" trackScanl
  , testCase "shows" trackShow
  , testCase "moves" trackMoves
  , testCase "loops" trackLoops
  , testCase "transform" trackTransform
  ]

testTrack = fromJust $ Track.parseTrack Track.start "srrsrr"

parseTestTrack :: Assertion
parseTestTrack = let
  tiles = Track.tile <$> testTrack
  in tiles @?= Loop.mkLoop [Track.Straight, Track.Right, Track.Right, Track.Straight, Track.Right, Track.Right]

parseBadTrack :: Assertion
parseBadTrack = Track.parseTrack Track.start "fail" @?= Nothing

trackNextSegment :: Assertion
trackNextSegment = let
  (Track.Segment tile p t) = Track.nextSegment Track.start Track.Right
  in do
    tile @?= Track.Right
    p @?= V2 Track.trackLength 0
    getMat t @?= V2 Track.trackUnitVector (V2 0 1)

trackScanl :: Assertion
trackScanl = let
  [x, y, z] = scanl Track.nextSegment Track.start [Track.Right, Track.Right]
  (Track.Segment x_tile x_p x_t) = x
  (Track.Segment y_tile y_p y_t) = y
  (Track.Segment z_tile z_p z_t) = z
  in do
    x_tile @?= Track.Straight
    x_p @?= zero
    getMat x_t @?= V2 Track.trackUnitVector (V2 0 1)

    y_tile @?= Track.Right
    y_p @?= V2 Track.trackLength 0
    getMat y_t @?= V2 Track.trackUnitVector (V2 0 1)

    z_tile @?= Track.Right
    z_p @?= V2 (Track.trackLength + Track.cornerWidth) Track.cornerWidth
    getMat z_t @?= V2 (V2 0 1) (V2 (-1) 0)

trackStart :: Assertion
trackStart = let
  Loop.Loop _ (Loop.Start start) _  = testTrack
  Track.Segment startTile _ _ = start
  in startTile @?= Track.Straight

trackLength :: Assertion
trackLength = Loop.length testTrack  @?= 6

trackShow :: Assertion
trackShow = let string = concatMap (show . Track.tile) . Loop.unfold $ testTrack
            in string @?= "srrsrr"

trackMoves :: Assertion
trackMoves = let
  lengthNub = length . nubBy ((==) `on` Track.position) . Loop.unfold
  in lengthNub testTrack @?= Loop.length testTrack

trackLoops :: Assertion
trackLoops = let
  Loop.Loop _ (Loop.Node end) _ = Loop.prev testTrack
  Track.Segment tile p t = end
  in show (Track.nextSegment end Track.Straight) @?= show Track.start

trackTransform :: Assertion
trackTransform = do
  transformFromAngle eye 0 @?= mkTransform (V2 (V2 1 0) (V2 0 1))
  (round <$>) <$> getMat (transformFromAngle eye (pi / 2) ) @?= V2 (V2 0 1) (V2 (-1) 0)
  (round <$>) <$> getMat (transformFromAngle eye pi ) @?= V2 (V2 (-1) 0) (V2 0 (-1))
  (round <$>) <$> getMat (transformFromAngle eye (3* (pi/2)) ) @?= V2 (V2 0 (-1)) (V2 1 0)

  Transform.angleFromTransform (mkTransform (V2 (V2 1 0) (V2 0 1))) @?= 0
  Transform.angleFromTransform (mkTransform (V2 (V2 0 1) (V2 (-1) 0))) @?= (pi/2)
  Transform.angleFromTransform (transformFromAngle eye 0) @?= 0
  Transform.angleFromTransform (transformFromAngle eye (pi/2)) @?= (pi/2)
  Transform.angleFromTransform (transformFromAngle eye 2) @?= 2

trackTrackingTests :: TestTree
trackTrackingTests = testGroup "Track tracking"
  [ testCase "track" trackTrackingTrack
  , testCase "rotated" trackTracking
  -- , testCase "pertubations" trackTrackingPertubations
  ]

trackTrackingTrack :: Assertion
trackTrackingTrack = do
  track <- fromJust <$> TT.track idleNoCars
  renderImage "/tmp/trackTrackerOutline.png" $ drawTrackOutline idleNoCars track

trackTracking :: Assertion
trackTracking = do
  (frames :: [FrameGrabber.TestMat]) <- FrameGrabber.getFrames "test/video/idle-no-cars-0-3-frames.mp4"
  outlines <- mapM maybeOutline frames
  FrameWriter.writeFrames "/tmp/trackTracking.mov" outlines

trackTrackingPertubations :: Assertion
trackTrackingPertubations = do
  (frames :: [FrameGrabber.TestMat]) <- FrameGrabber.getFrames "test/video/track/pertubations.mov"
  outlines <- mapM maybeOutline frames
  FrameWriter.writeFrames "/tmp/trackTrackingPertubations.mov" outlines

maybeOutline :: FrameGrabber.TestMat -> IO FrameGrabber.TestMat
maybeOutline frame = do
  maybeTrack <- TT.track frame
  case maybeTrack of
    Nothing -> return frame
    Just track -> return $ drawTrackOutline frame track

ext: hs

max_stars_repo_name: dukedave/pitchskell

max_issues_repo_name: dukedave/pitchskell

max_forks_repo_name: dukedave/pitchskell


text:
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Witch.Instances where

import qualified Control.Exception as Exception
import qualified Data.Bits as Bits
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.ByteString.Short as ShortByteString
import qualified Data.Complex as Complex
import qualified Data.Fixed as Fixed
import qualified Data.Foldable as Foldable
import qualified Data.Int as Int
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Ratio as Ratio
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText
import qualified Data.Time as Time
import qualified Data.Time.Clock.POSIX as Time
import qualified Data.Time.Clock.System as Time
import qualified Data.Time.Clock.TAI as Time
import qualified Data.Word as Word
import qualified GHC.Float as Float
import qualified Numeric
import qualified Numeric.Natural as Natural
import qualified Witch.From as From
import qualified Witch.TryFrom as TryFrom
import qualified Witch.TryFromException as TryFromException
import qualified Witch.Utility as Utility

-- | Uses 'id'.
instance From.From a a where
  from = id

-- Int8

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Int.Int16 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Int.Int32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Int where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int.Int8 Natural.Natural where
  tryFrom = Utility.eitherTryFrom fromNonNegativeIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Float where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Double where
  from = fromIntegral

-- Int16

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Int.Int32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Int where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int.Int16 Natural.Natural where
  tryFrom = Utility.eitherTryFrom fromNonNegativeIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Float where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Double where
  from = fromIntegral

-- Int32

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int.Int32 Int.Int64 where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int.Int32 Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int.Int32 Natural.Natural where
  tryFrom = Utility.eitherTryFrom fromNonNegativeIntegral

-- | Uses 'fromIntegral' when the input is between -16,777,215 and 16,777,215
-- inclusive.
instance TryFrom.TryFrom Int.Int32 Float where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxFloat
    then Left Exception.Underflow
    else if s > maxFloat
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- | Uses 'fromIntegral'.
instance From.From Int.Int32 Double where
  from = fromIntegral

-- Int64

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int.Int64 Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int.Int64 Natural.Natural where
  -- This should use @eitherTryFrom fromNonNegativeIntegral@, but that causes
  -- a bug in GHC 9.0.1.
  -- https://mail.haskell.org/pipermail/haskell-cafe/2021-March/133540.html
  tryFrom =
    Utility.eitherTryFrom $ \s -> TryFrom.tryFrom (From.from s :: Integer)

-- | Uses 'fromIntegral' when the input is between -16,777,215 and 16,777,215
-- inclusive.
instance TryFrom.TryFrom Int.Int64 Float where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxFloat
    then Left Exception.Underflow
    else if s > maxFloat
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- | Uses 'fromIntegral' when the input is between -9,007,199,254,740,991 and
-- 9,007,199,254,740,991 inclusive.
instance TryFrom.TryFrom Int.Int64 Double where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxDouble
    then Left Exception.Underflow
    else if s > maxDouble
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- Int

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int Natural.Natural where
  tryFrom = Utility.eitherTryFrom fromNonNegativeIntegral

-- | Uses 'fromIntegral' when the input is between -16,777,215 and 16,777,215
-- inclusive.
instance TryFrom.TryFrom Int Float where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxFloat
    then Left Exception.Underflow
    else if s > maxFloat
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- | Uses 'fromIntegral' when the input is between -9,007,199,254,740,991 and
-- 9,007,199,254,740,991 inclusive.
instance TryFrom.TryFrom Int Double where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if toInteger (maxBound :: Int) <= maxDouble
      then Right $ fromIntegral s
      else if s < -maxDouble
        then Left Exception.Underflow
        else if s > maxDouble
          then Left Exception.Overflow
          else Right $ fromIntegral s

-- Integer

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int.Int64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromInteger' when the input is not negative.
instance TryFrom.TryFrom Integer Natural.Natural where
  -- This should use @eitherTryFrom fromNonNegativeIntegral@, but that causes
  -- a bug in GHC 9.0.1. By inlining @fromNonNegativeIntegral@ and replacing
  -- @fromIntegral@ with @fromInteger@, we can work around the bug.
  -- https://mail.haskell.org/pipermail/haskell-cafe/2021-March/133540.html
  tryFrom = Utility.eitherTryFrom
    $ \s -> if s < 0 then Left Exception.Underflow else Right $ fromInteger s

-- | Uses 'fromIntegral' when the input is between -16,777,215 and 16,777,215
-- inclusive.
instance TryFrom.TryFrom Integer Float where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxFloat
    then Left Exception.Underflow
    else if s > maxFloat
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- | Uses 'fromIntegral' when the input is between -9,007,199,254,740,991 and
-- 9,007,199,254,740,991 inclusive.
instance TryFrom.TryFrom Integer Double where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxDouble
    then Left Exception.Underflow
    else if s > maxDouble
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- Word8

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Word.Word16 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Word.Word32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Word.Word64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Word where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Natural.Natural where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word8 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Int.Int16 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Int.Int32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Int where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Integer where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Float where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Double where
  from = fromIntegral

-- Word16

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word16 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Word.Word32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Word.Word64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Word where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Natural.Natural where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word16 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word16 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Int.Int32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Int where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Integer where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Float where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Double where
  from = fromIntegral

-- Word32

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Word.Word64 where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Natural.Natural where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Int.Int64 where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Integer where
  from = fromIntegral

-- | Uses 'fromIntegral' when the input is less than or equal to 16,777,215.
instance TryFrom.TryFrom Word.Word32 Float where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxFloat then Right $ fromIntegral s else Left Exception.Overflow

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Double where
  from = fromIntegral

-- Word64

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word64 Natural.Natural where
  -- This should use @fromIntegral@, but that causes a bug in GHC 9.0.1.
  -- https://mail.haskell.org/pipermail/haskell-cafe/2021-March/133540.html
  from s = Utility.unsafeFrom (From.from s :: Integer)

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int.Int64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word64 Integer where
  from = fromIntegral

-- | Uses 'fromIntegral' when the input is less than or equal to 16,777,215.
instance TryFrom.TryFrom Word.Word64 Float where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxFloat then Right $ fromIntegral s else Left Exception.Overflow

-- | Uses 'fromIntegral' when the input is less than or equal to
-- 9,007,199,254,740,991.
instance TryFrom.TryFrom Word.Word64 Double where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxDouble then Right $ fromIntegral s else Left Exception.Overflow

-- Word

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word Word.Word64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word Natural.Natural where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int.Int64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word Integer where
  from = fromIntegral

-- | Uses 'fromIntegral' when the input is less than or equal to 16,777,215.
instance TryFrom.TryFrom Word Float where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxFloat then Right $ fromIntegral s else Left Exception.Overflow

-- | Uses 'fromIntegral' when the input is less than or equal to
-- 9,007,199,254,740,991.
instance TryFrom.TryFrom Word Double where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if (toInteger (maxBound :: Word) <= maxDouble) || (s <= maxDouble)
      then Right $ fromIntegral s
      else Left Exception.Overflow

-- Natural

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int.Int64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Natural.Natural Integer where
  from = fromIntegral

-- | Uses 'fromIntegral' when the input is less than or equal to 16,777,215.
instance TryFrom.TryFrom Natural.Natural Float where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxFloat then Right $ fromIntegral s else Left Exception.Overflow

-- | Uses 'fromIntegral' when the input is less than or equal to
-- 9,007,199,254,740,991.
instance TryFrom.TryFrom Natural.Natural Double where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxDouble then Right $ fromIntegral s else Left Exception.Overflow

-- Float

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int.Int8 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int.Int16 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int.Int32 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int.Int64 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Rational' when the input is between -16,777,215 and
-- 16,777,215 inclusive.
instance TryFrom.TryFrom Float Integer where
  tryFrom = Utility.eitherTryFrom $ \s -> case Utility.tryVia @Rational s of
    Left e -> Left $ Exception.toException e
    Right t
      | t < -maxFloat -> Left $ Exception.toException Exception.Underflow
      | t > maxFloat -> Left $ Exception.toException Exception.Overflow
      | otherwise -> Right t

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word.Word8 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word.Word16 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word.Word32 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word.Word64 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Natural.Natural where
  tryFrom = Utility.tryVia @Integer

-- | Uses 'Numeric.floatToDigits' when the input is not NaN or infinity.
instance TryFrom.TryFrom Float Rational where
  tryFrom = Utility.eitherTryFrom realFloatToRational

-- | Uses 'Float.float2Double'.
instance From.From Float Double where
  from = Float.float2Double

-- Double

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int.Int8 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int.Int16 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int.Int32 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int.Int64 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Rational' when the input is between -9,007,199,254,740,991
-- and 9,007,199,254,740,991 inclusive.
instance TryFrom.TryFrom Double Integer where
  tryFrom = Utility.eitherTryFrom $ \s -> case Utility.tryVia @Rational s of
    Left e -> Left $ Exception.toException e
    Right t
      | t < -maxDouble -> Left $ Exception.toException Exception.Underflow
      | t > maxDouble -> Left $ Exception.toException Exception.Overflow
      | otherwise -> Right t

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word.Word8 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word.Word16 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word.Word32 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word.Word64 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Natural.Natural where
  tryFrom = Utility.tryVia @Integer

-- | Uses 'Numeric.floatToDigits' when the input is not NaN or infinity.
instance TryFrom.TryFrom Double Rational where
  tryFrom = Utility.eitherTryFrom realFloatToRational

-- | Uses 'Float.double2Float'. This necessarily loses some precision.
instance From.From Double Float where
  from = Float.double2Float

-- Ratio

-- | Uses '(Ratio.%)' with a denominator of 1.
instance Integral a => From.From a (Ratio.Ratio a) where
  from = (Ratio.% 1)

-- | Uses 'Ratio.numerator' when the denominator is 1.
instance (Eq a, Num a) => TryFrom.TryFrom (Ratio.Ratio a) a where
  tryFrom = Utility.eitherTryFrom $ \s -> if Ratio.denominator s == 1
    then Right $ Ratio.numerator s
    else Left Exception.LossOfPrecision

-- | Uses 'fromRational'. This necessarily loses some precision.
instance From.From Rational Float where
  from = fromRational

-- | Uses 'fromRational'. This necessarily loses some precision.
instance From.From Rational Double where
  from = fromRational

-- | Uses `fromRational` as long as there isn't a loss of precision.
instance Fixed.HasResolution a => TryFrom.TryFrom Rational (Fixed.Fixed a) where
  tryFrom = Utility.eitherTryFrom $ \s ->
    let
      t :: Fixed.Fixed a
      t = fromRational s
    in if toRational t == s then Right t else Left Exception.LossOfPrecision

-- Fixed

-- | Uses 'Fixed.MkFixed'. This means @from \@Integer \@Centi 2@ is @0.02@
-- rather than @2.00@.
instance From.From Integer (Fixed.Fixed a) where
  from = Fixed.MkFixed

-- | Uses 'Fixed.MkFixed'. This means @from \@Centi \@Integer 3.00@ is @300@
-- rather than @3@.
instance From.From (Fixed.Fixed a) Integer where
  from (Fixed.MkFixed t) = t

-- | Uses 'toRational'.
instance Fixed.HasResolution a => From.From (Fixed.Fixed a) Rational where
  from = toRational

-- Complex

-- | Uses '(Complex.:+)' with an imaginary part of 0.
instance Num a => From.From a (Complex.Complex a) where
  from = (Complex.:+ 0)

-- | Uses 'Complex.realPart' when the imaginary part is 0.
instance (Eq a, Num a) => TryFrom.TryFrom (Complex.Complex a) a where
  tryFrom = Utility.eitherTryFrom $ \s -> if Complex.imagPart s == 0
    then Right $ Complex.realPart s
    else Left Exception.LossOfPrecision

-- NonEmpty

-- | Uses 'NonEmpty.nonEmpty'.
instance TryFrom.TryFrom [a] (NonEmpty.NonEmpty a) where
  tryFrom = Utility.maybeTryFrom NonEmpty.nonEmpty

-- | Uses 'NonEmpty.toList'.
instance From.From (NonEmpty.NonEmpty a) [a] where
  from = NonEmpty.toList

-- Set

-- | Uses 'Set.fromList'.
instance Ord a => From.From [a] (Set.Set a) where
  from = Set.fromList

-- | Uses 'Set.toAscList'.
instance From.From (Set.Set a) [a] where
  from = Set.toAscList

-- IntSet

-- | Uses 'IntSet.fromList'.
instance From.From [Int] IntSet.IntSet where
  from = IntSet.fromList

-- | Uses 'IntSet.toAscList'.
instance From.From IntSet.IntSet [Int] where
  from = IntSet.toAscList

-- Map

-- | Uses 'Map.fromList'. If there are duplicate keys, later values will
-- overwrite earlier ones.
instance Ord k => From.From [(k, v)] (Map.Map k v) where
  from = Map.fromList

-- | Uses 'Map.toAscList'.
instance From.From (Map.Map k v) [(k, v)] where
  from = Map.toAscList

-- IntMap

-- | Uses 'IntMap.fromList'. If there are duplicate keys, later values will
-- overwrite earlier ones.
instance From.From [(Int, v)] (IntMap.IntMap v) where
  from = IntMap.fromList

-- | Uses 'IntMap.toAscList'.
instance From.From (IntMap.IntMap v) [(Int, v)] where
  from = IntMap.toAscList

-- Seq

-- | Uses 'Seq.fromList'.
instance From.From [a] (Seq.Seq a) where
  from = Seq.fromList

-- | Uses 'Foldable.toList'.
instance From.From (Seq.Seq a) [a] where
  from = Foldable.toList

-- ByteString

-- | Uses 'ByteString.pack'.
instance From.From [Word.Word8] ByteString.ByteString where
  from = ByteString.pack

-- | Uses 'ByteString.unpack'.
instance From.From ByteString.ByteString [Word.Word8] where
  from = ByteString.unpack

-- | Uses 'LazyByteString.fromStrict'.
instance From.From ByteString.ByteString LazyByteString.ByteString where
  from = LazyByteString.fromStrict

-- | Uses 'ShortByteString.toShort'.
instance From.From ByteString.ByteString ShortByteString.ShortByteString where
  from = ShortByteString.toShort

-- | Uses 'Text.decodeUtf8''.
instance TryFrom.TryFrom ByteString.ByteString Text.Text where
  tryFrom = Utility.eitherTryFrom Text.decodeUtf8'

-- | Converts via 'Text.Text'.
instance TryFrom.TryFrom ByteString.ByteString LazyText.Text where
  tryFrom =
    Utility.eitherTryFrom
      $ fmap (Utility.into @LazyText.Text)
      . Utility.tryInto @Text.Text

-- | Converts via 'Text.Text'.
instance TryFrom.TryFrom ByteString.ByteString String where
  tryFrom =
    Utility.eitherTryFrom
      $ fmap (Utility.into @String)
      . Utility.tryInto @Text.Text

-- LazyByteString

-- | Uses 'LazyByteString.pack'.
instance From.From [Word.Word8] LazyByteString.ByteString where
  from = LazyByteString.pack

-- | Uses 'LazyByteString.unpack'.
instance From.From LazyByteString.ByteString [Word.Word8] where
  from = LazyByteString.unpack

-- | Uses 'LazyByteString.toStrict'.
instance From.From LazyByteString.ByteString ByteString.ByteString where
  from = LazyByteString.toStrict

-- | Uses 'LazyText.decodeUtf8''.
instance TryFrom.TryFrom LazyByteString.ByteString LazyText.Text where
  tryFrom = Utility.eitherTryFrom LazyText.decodeUtf8'

-- | Converts via 'LazyText.Text'.
instance TryFrom.TryFrom LazyByteString.ByteString Text.Text where
  tryFrom =
    Utility.eitherTryFrom
      $ fmap (Utility.into @Text.Text)
      . Utility.tryInto @LazyText.Text

-- | Converts via 'LazyText.Text'.
instance TryFrom.TryFrom LazyByteString.ByteString String where
  tryFrom =
    Utility.eitherTryFrom
      $ fmap (Utility.into @String)
      . Utility.tryInto @LazyText.Text

-- ShortByteString

-- | Uses 'ShortByteString.pack'.
instance From.From [Word.Word8] ShortByteString.ShortByteString where
  from = ShortByteString.pack

-- | Uses 'ShortByteString.unpack'.
instance From.From ShortByteString.ShortByteString [Word.Word8] where
  from = ShortByteString.unpack

-- | Uses 'ShortByteString.fromShort'.
instance From.From ShortByteString.ShortByteString ByteString.ByteString where
  from = ShortByteString.fromShort

-- Text

-- | Uses 'LazyText.fromStrict'.
instance From.From Text.Text LazyText.Text where
  from = LazyText.fromStrict

-- | Uses 'Text.encodeUtf8'.
instance From.From Text.Text ByteString.ByteString where
  from = Text.encodeUtf8

-- | Converts via 'ByteString.ByteString'.
instance From.From Text.Text LazyByteString.ByteString where
  from = Utility.via @ByteString.ByteString

-- LazyText

-- | Uses 'LazyText.toStrict'.
instance From.From LazyText.Text Text.Text where
  from = LazyText.toStrict

-- | Uses 'LazyText.encodeUtf8'.
instance From.From LazyText.Text LazyByteString.ByteString where
  from = LazyText.encodeUtf8

-- | Converts via 'LazyByteString.ByteString'.
instance From.From LazyText.Text ByteString.ByteString where
  from = Utility.via @LazyByteString.ByteString

-- String

-- | Uses 'Text.pack'. Some 'Char' values cannot be represented in 'Text.Text'
-- and will be replaced with @'\\xFFFD'@.
instance From.From String Text.Text where
  from = Text.pack

-- | Uses 'Text.unpack'.
instance From.From Text.Text String where
  from = Text.unpack

-- | Uses 'LazyText.pack'. Some 'Char' values cannot be represented in
-- 'LazyText.Text' and will be replaced with @'\\xFFFD'@.
instance From.From String LazyText.Text where
  from = LazyText.pack

-- | Uses 'LazyText.unpack'.
instance From.From LazyText.Text String where
  from = LazyText.unpack

-- | Converts via 'Text.Text'.
instance From.From String ByteString.ByteString where
  from = Utility.via @Text.Text

-- | Converts via 'LazyText.Text'.
instance From.From String LazyByteString.ByteString where
  from = Utility.via @LazyText.Text

-- TryFromException

-- | Uses @coerce@.
instance From.From
  (TryFromException.TryFromException source oldTarget)
  (TryFromException.TryFromException source newTarget)

-- Day

-- | Uses 'Time.ModifiedJulianDay'.
instance From.From Integer Time.Day where
  from = Time.ModifiedJulianDay

-- | Uses 'Time.toModifiedJulianDay'.
instance From.From Time.Day Integer where
  from = Time.toModifiedJulianDay

-- DayOfWeek

-- | Uses 'Time.dayOfWeek'.
instance From.From Time.Day Time.DayOfWeek where
  from = Time.dayOfWeek

-- UniversalTime

-- | Uses 'Time.ModJulianDate'.
instance From.From Rational Time.UniversalTime where
  from = Time.ModJulianDate

-- | Uses 'Time.getModJulianDate'.
instance From.From Time.UniversalTime Rational where
  from = Time.getModJulianDate

-- DiffTime

-- | Uses 'realToFrac'.
instance From.From Fixed.Pico Time.DiffTime where
  from = realToFrac

-- | Uses 'realToFrac'.
instance From.From Time.DiffTime Fixed.Pico where
  from = realToFrac

-- NominalDiffTime

-- | Uses 'Time.secondsToNominalDiffTime'.
instance From.From Fixed.Pico Time.NominalDiffTime where
  from = Time.secondsToNominalDiffTime

-- | Uses 'Time.nominalDiffTimeToSeconds'.
instance From.From Time.NominalDiffTime Fixed.Pico where
  from = Time.nominalDiffTimeToSeconds

-- POSIXTime

-- | Uses 'Time.systemToPOSIXTime'.
instance From.From Time.SystemTime Time.POSIXTime where
  from = Time.systemToPOSIXTime

-- | Uses 'Time.utcTimeToPOSIXSeconds'.
instance From.From Time.UTCTime Time.POSIXTime where
  from = Time.utcTimeToPOSIXSeconds

-- | Uses 'Time.posixSecondsToUTCTime'.
instance From.From Time.POSIXTime Time.UTCTime where
  from = Time.posixSecondsToUTCTime

-- SystemTime

-- | Uses 'Time.utcToSystemTime'.
instance From.From Time.UTCTime Time.SystemTime where
  from = Time.utcToSystemTime

-- | Uses 'Time.systemToTAITime'.
instance From.From Time.SystemTime Time.AbsoluteTime where
  from = Time.systemToTAITime

-- | Uses 'Time.systemToUTCTime'.
instance From.From Time.SystemTime Time.UTCTime where
  from = Time.systemToUTCTime

-- TimeOfDay

-- | Uses 'Time.timeToTimeOfDay'.
instance From.From Time.DiffTime Time.TimeOfDay where
  from = Time.timeToTimeOfDay

-- | Uses 'Time.dayFractionToTimeOfDay'.
instance From.From Rational Time.TimeOfDay where
  from = Time.dayFractionToTimeOfDay

-- | Uses 'Time.timeOfDayToTime'.
instance From.From Time.TimeOfDay Time.DiffTime where
  from = Time.timeOfDayToTime

-- | Uses 'Time.timeOfDayToDayFraction'.
instance From.From Time.TimeOfDay Rational where
  from = Time.timeOfDayToDayFraction

-- CalendarDiffTime

-- | Uses 'Time.calendarTimeDays'.
instance From.From Time.CalendarDiffDays Time.CalendarDiffTime where
  from = Time.calendarTimeDays

-- | Uses 'Time.calendarTimeTime'.
instance From.From Time.NominalDiffTime Time.CalendarDiffTime where
  from = Time.calendarTimeTime

-- ZonedTime

-- | Uses 'Time.zonedTimeToUTC'.
instance From.From Time.ZonedTime Time.UTCTime where
  from = Time.zonedTimeToUTC

--

realFloatToRational
  :: RealFloat s => s -> Either Exception.ArithException Rational
realFloatToRational s
  | isNaN s = Left Exception.LossOfPrecision
  | isInfinite s = if s > 0
    then Left Exception.Overflow
    else Left Exception.Underflow
  | otherwise = Right $ overPositive
    (uncurry makeRational . uncurry fromDigits . Numeric.floatToDigits 10)
    s

overPositive :: (Eq a, Num a, Num b) => (a -> b) -> a -> b
overPositive f x = if signum x == -1 then -(f (-x)) else f x

fromDigits :: [Int] -> Int -> (Integer, Integer)
fromDigits ds e =
  List.foldl' (\(a, n) d -> (a * 10 + toInteger d, n - 1)) (0, toInteger e) ds

makeRational :: Integer -> Integer -> Rational
makeRational d e = toRational d * 10 ^^ e

fromNonNegativeIntegral
  :: (Integral s, Num t) => s -> Either Exception.ArithException t
fromNonNegativeIntegral x =
  if x < 0 then Left Exception.Underflow else Right $ fromIntegral x

-- | The maximum integral value that can be unambiguously represented as a
-- 'Float'. Equal to 16,777,215.
maxFloat :: Num a => a
maxFloat = 16777215

-- | The maximum integral value that can be unambiguously represented as a
-- 'Double'. Equal to 9,007,199,254,740,991.
maxDouble :: Num a => a
maxDouble = 9007199254740991

max_stars_repo_name: tfausak/witch

max_issues_repo_name: tfausak/witch

max_forks_repo_name: tfausak/witch


text:
-- | The Metropolis transition.

module Strategy.Metropolis (metropolis) where

import Control.Monad.State.Strict
import Data.Maybe
import Numeric.LinearAlgebra
import Math.Probably.Sampler
import Math.Probably.Types
import Math.Probably.Utils

-- | The Metropolis transition for a symmetric proposal.  Uses a simple
--   spherical Gaussian with standard deviation specified by the first
--   argument.
metropolis :: Maybe Double -> Transition Double
metropolis e = do
  Chain current@(ds, cs) target _ t <- get
  let sd = fromMaybe t e
  pcs <- lift $ perturb cs sd
  zc  <- lift unit
  let next = nextState target current (ds, pcs) sd zc
  put $ Chain next target (logObjective target next) sd
  return next

perturb :: ContinuousParams -> Double -> Prob (ContinuousParams)
perturb q sd = fmap fromList $ mapM (`normal` sd) (toList q)

acceptRatio :: Target -> Parameters -> Parameters -> Double -> Double
acceptRatio target c@(_, current) p@(_, proposed) sd = exp . min 0 $
    logObjective target p + log (sphereGauss current proposed sd)
  - logObjective target c - log (sphereGauss proposed current sd)

nextState
  :: Target
  -> Parameters
  -> Parameters
  -> Double
  -> Double
  -> Parameters
nextState target current proposed sd z
    | z < acceptProb = proposed
    | otherwise      = current
  where
    ratio = acceptRatio target current proposed sd
    acceptProb | isNaN ratio = 0
               | otherwise   = ratio

max_stars_repo_name: glutamate/probably-baysig

max_issues_repo_name: silky/probably-baysig

max_forks_repo_name: silky/probably-baysig


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

import qualified Data.Vector as V
import qualified NumHask.Array.Dynamic as D
import qualified NumHask.Array.Fixed as F
import qualified NumHask.Array.HMatrix as H
import qualified Numeric.LinearAlgebra as HMatrix
import Perf
import NumHask.Prelude as P hiding (option)
import Data.Text (unpack, Text)
import Options.Applicative
import Control.Monad

data RunType = RunMMult | RunDotSum | RunDotVector deriving (Eq, Show)

data StatType = StatAverage | StatMedian | StatBest deriving (Eq, Show)

data Options = Options
  { optionRuns :: Int,
    optionMSize :: Int,
    optionMMult :: Bool,
    optionDotSum :: Bool,
    optionDotVector :: Bool,
    optionStatType :: StatType
  } deriving (Eq, Show)

options :: Parser Options
options = Options <$>
  option auto (long "runs" <> short 'r' <> help "number of runs to perform") <*>
  option auto (long "matrix-size" <> short 'm' <> help "size of square matrix") <*>
  switch (long "include matrix-multiplication calc" <> short 'x') <*>
  switch (long "dot-sum" <> help "include dot sum (+) calc" <> short 'd') <*>
  switch (long "dot-vector" <> help "include dot vector calc" <> short 'v') <*>
  stat

opts :: ParserInfo Options
opts = info (options <**> helper)
  (fullDesc <> progDesc "benchmark testing" <> header "A performance benchmark for numhask")

stat :: Parser StatType
stat =
  flag' StatBest (long "best" <> help "report upper decile") <|>
  flag' StatMedian (long "median" <> help "report median") <|>
  pure StatAverage

tickStat :: StatType -> [Cycle] -> Text
tickStat StatBest = tenth
tickStat StatMedian = median
tickStat StatAverage = average

main :: IO ()
main = do
  o <- execParser opts
  let !n = optionRuns o
  let s = optionStatType o
  _ <- warmup 100

  putStrLn "mmult 10x10"

  when (optionMMult o) $ do
    runHMatrix s n
    runNHHMatrix s n
    runF s n
    runD s n
    when (optionDotSum o) (runFDS s n)

  when (optionDotVector o) $ do
    runDotV s n
    runDotF s n
    runDotD s n

runHMatrix :: StatType -> Int -> IO ()
runHMatrix s n = do
  -- HMatrix 10x10 matrix multiplication
  let ticksH x = ticks n (x HMatrix.<>) x
  let !h10 = (10 HMatrix.>< 10) [1 :: HMatrix.R ..]
  th10 <- ticksH h10
  putStrLn $ unpack $ "hmatrix " <> tickStat s (fst th10)

runNHHMatrix :: StatType -> Int -> IO ()
runNHHMatrix s n = do
  -- NumHask.Array.HMatrix
  let ticksH' x = ticks n (x `H.mmult`) x
  let !h'10 = [1 .. 100] :: H.Array '[10, 10] Double
  th'10 <- ticksH' h'10
  putStrLn $ unpack $ "numhask-hmatrix " <> tickStat s (fst th'10)

runF :: StatType -> Int -> IO ()
runF s n = do
  -- NumHask.Array.Fixed
  let ticksF x = ticks n (x `F.mmult`) x
  let !f10 = [1 .. 100] :: F.Array '[10, 10] Double
  tf10 <- ticksF f10
  putStrLn $ unpack $ "Fixed " <> tickStat s (fst tf10)

runFDS :: StatType -> Int -> IO ()
runFDS s n = do
  -- NumHask.Array.Fixed.dot
  let ticksF x = ticks n (F.dot sum (+) x) x
  let !f10 = [1 .. 100] :: F.Array '[10, 10] Double
  tf10 <- ticksF f10
  putStrLn $ unpack $ "Fixed-dotsum " <> tickStat s (fst tf10)

runD :: StatType -> Int -> IO ()
runD s n = do
  -- NumHask.Array.Dynamic
  let !d10 = D.fromFlatList [10, 10] [1 .. 100] :: D.Array Double
  let ticksD x = ticks n (x `D.mmult`) x
  td10 <- ticksD d10
  putStrLn $ unpack $ "Dynamic " <> tickStat s (fst td10)

runDotV :: StatType -> Int -> IO ()
runDotV s n = do
  -- Vector dot
  let !vv = V.fromList [1 .. 100] :: V.Vector Double
  let ticksDotv x = ticks n (sum . V.zipWith (*) x) x
  tvd <- ticksDotv vv
  putStrLn $ unpack $ "Vector-dot " <> tickStat s (fst tvd)

runDotF :: StatType -> Int -> IO ()
runDotF s n = do
  -- Fixed Dot
  let !vf = P.fromList [1 .. 100] :: F.Array '[100] Double
  let ticksDotF x = ticks n (F.dot sum (+) x) x
  tfd <- ticksDotF vf
  putStrLn $ unpack $ "Fixed-dot " <> tickStat s (fst tfd)

runDotD :: StatType -> Int -> IO ()
runDotD s n = do
  -- Dynamic Dot
  let !vd = D.fromFlatList [100] [1 .. 100] :: D.Array Double
  let !vd2 = D.fromFlatList [100] [101 .. 200] :: D.Array Double
  let ticksDotD x = ticks n (D.dot sum (+) vd2) x
  tdd <- ticksDotD vd
  putStrLn $ unpack $ "Dynamic-dot " <> tickStat s (fst tdd)
  pure ()


text:
module Distr where

import MHMonad
import Statistics.Distribution
import Statistics.Distribution.Normal (normalDistr)
import Statistics.Distribution.Beta (betaDistr)
import Statistics.Distribution.Beta (betaDistr)
import Statistics.Distribution.Gamma (gammaDistr)
import qualified Statistics.Distribution.Poisson as Poisson
import Data.List

categorical :: [Double] -> Meas Integer
categorical rs = do r <- sample
                    return $ categ rs r

normal :: Double -> Double -> Meas Double
normal m s = do x <- sample
                return $ quantile (normalDistr m s) x

normalPdf :: Double -> Double -> Double -> Double
normalPdf m s = density $ normalDistr m s

exponential :: Double -> Meas Double
exponential rate =
  do x <- sample
     return $ - (log x / rate)

expPdf :: Double -> Double -> Double
expPdf rate x = exp (-rate*x) * rate

gamma :: Double -> Double -> Meas Double
gamma a b = do
  x <- sample
  return $ quantile (gammaDistr a b) x

beta :: Double -> Double -> Meas Double
beta a b = do
  x <- sample
  return $ quantile (betaDistr a b) x

poisson :: Double -> Meas Integer
poisson lambda = do
  x <- sample
  let cmf = scanl1 (+) $ map (probability $ Poisson.poisson lambda) $ [0,1..]
  let (Just n) = findIndex (\r -> r > x) cmf
  return $ fromIntegral n

poissonPdf :: Double -> Integer -> Double
poissonPdf rate n = probability (Poisson.poisson rate) (fromIntegral n)

dirichlet :: [Double] -> Meas[Double]
dirichlet as = do
  xs <- mapM exponential as
  let s = Prelude.sum xs
  let ys = map (/ s) xs
  return ys

bernoulli :: Double -> Meas Bool
bernoulli r = do
  x <- sample
  return $ x < r

max_stars_repo_name: PiotrJander/oplss-staton

max_issues_repo_name: PiotrJander/oplss-staton

max_forks_repo_name: PiotrJander/oplss-staton


text:
{-# LANGUAGE CPP, NoImplicitPrelude #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif
module SafeHaskellSpec (main, spec) where

import TestHspecTrustworthy

-- The following modules should not be Unsafe (#56):
import Control.Concurrent.Compat ()
import Control.Concurrent.MVar.Compat ()
import Control.Exception.Compat ()
import Control.Monad.Compat ()
import Control.Monad.Fail.Compat ()
import Control.Monad.IO.Class.Compat ()
import Data.Bifoldable.Compat ()
import Data.Bifunctor.Compat ()
import Data.Bitraversable.Compat ()
import Data.Bits.Compat ()
import Data.Bool.Compat ()
import Data.Complex.Compat ()
import Data.Either.Compat ()
import Data.Foldable.Compat ()
import Data.Function.Compat ()
import Data.Functor.Compat ()
import Data.Functor.Compose.Compat ()
import Data.Functor.Const.Compat ()
import Data.Functor.Contravariant.Compat ()
import Data.Functor.Identity.Compat ()
import Data.Functor.Product.Compat ()
import Data.Functor.Sum.Compat ()
import Data.IORef.Compat ()
import Data.List.Compat ()
import Data.List.NonEmpty.Compat ()
import Data.Monoid.Compat ()
import Data.Proxy.Compat ()
import Data.Ratio.Compat ()
import Data.Semigroup.Compat ()
import Data.STRef.Compat ()
import Data.String.Compat ()
import Data.Type.Coercion.Compat ()
import Data.Type.Equality.Compat ()
import Data.Version.Compat ()
import Data.Void.Compat ()
import Data.Word.Compat ()
import Foreign.Compat ()
import Foreign.ForeignPtr.Compat ()
import Foreign.ForeignPtr.Safe.Compat ()
import Foreign.Marshal.Alloc.Compat ()
import Foreign.Marshal.Array.Compat ()
import Foreign.Marshal.Compat ()
import Foreign.Marshal.Safe.Compat ()
import Foreign.Marshal.Utils.Compat ()
import Numeric.Compat ()
import Numeric.Natural.Compat ()
import Prelude.Compat
import System.Environment.Compat ()
import System.Exit.Compat ()
import System.IO.Error ()
import Text.Read.Compat ()
import Type.Reflection.Compat ()

main :: IO ()
main = hspec spec

spec :: Spec
spec = pure ()

max_stars_repo_name: kozross/base-compat

max_issues_repo_name: kozross/base-compat

max_forks_repo_name: kozross/base-compat


text:
-- `PolyKinds` ensures the derived HasRep instances are fully polymorphic. In future, we could try
-- to make this explicit in `deriveHasRep`.
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | The only module that should be needed by code that is in the dependency graph of calls to
--  `Categorifier.Categorify.expression`. If the module actually /calls/
--  `Categorifier.Categorify.expression`, then it will also need to
--   @import qualified "Categorifier.Categorify" as Categorify@.
module Categorifier.Client
  ( HasRep (..),
    Rep,
    deriveHasRep,

    -- * testing
    abstReturn,
    reprReturn,
  )
where

import Categorifier.Client.Internal (HasRep (..), Rep, deriveHasRep)
import Data.Complex (Complex)
import Data.Functor.Compose (Compose)
import Data.Functor.Identity (Identity)
import qualified Data.Functor.Product as Functor
import qualified Data.Functor.Sum as Functor
import Data.List.NonEmpty (NonEmpty)
import Data.Proxy (Proxy (..))
import Data.Ratio (Ratio)
import qualified Data.Semigroup as Semigroup
import qualified GHC.Generics as Generic

-- | This property should be true for every `HasRep` instance. `r` should be a classifying object,
--   and the first argument a comparison (e.g., `Bool` and `==` or `Hedgehog.Property` and
--  `Hedgehog.===`) to make it easy to test.
abstReturn :: forall a r. HasRep a => Proxy a -> (Rep a -> Rep a -> r) -> Rep a -> r
abstReturn Proxy eq = eq <$> id <*> repr . abst @a

-- | This property should be true for every `HasRep` instance. `r` should be a classifying object,
--   and the first argument a comparison (e.g., `Bool` and `==` or `Hedgehog.Property` and
--  `Hedgehog.===`) to make it easy to test.
reprReturn :: HasRep a => (a -> a -> r) -> a -> r
reprReturn eq = eq <$> id <*> abst . repr

deriveHasRep ''[]
deriveHasRep ''(,,)
deriveHasRep ''(,,,)
deriveHasRep ''(,,,,)
deriveHasRep ''(,,,,,)
deriveHasRep ''(,,,,,,)
deriveHasRep ''(,,,,,,,)
deriveHasRep ''(,,,,,,,,)
deriveHasRep ''(,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveHasRep ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveHasRep ''Complex
deriveHasRep ''Compose
deriveHasRep ''Functor.Product
deriveHasRep ''Functor.Sum
deriveHasRep ''(Generic.:+:)
deriveHasRep ''(Generic.:*:)
deriveHasRep ''(Generic.:.:)
deriveHasRep ''Generic.K1
deriveHasRep ''Generic.M1
deriveHasRep ''Generic.Par1
deriveHasRep ''Generic.U1
deriveHasRep ''Identity
deriveHasRep ''Maybe
deriveHasRep ''NonEmpty
deriveHasRep ''Ordering
deriveHasRep ''Proxy
deriveHasRep ''Ratio
deriveHasRep ''Semigroup.All
deriveHasRep ''Semigroup.Any
deriveHasRep ''Semigroup.Dual
deriveHasRep ''Semigroup.Endo
deriveHasRep ''Semigroup.Max
deriveHasRep ''Semigroup.Min
deriveHasRep ''Semigroup.Product
deriveHasRep ''Semigroup.Sum

max_stars_repo_name: con-kitty/categorifier

max_issues_repo_name: con-kitty/categorifier

max_forks_repo_name: con-kitty/categorifier