extensible 0.4.6 → 0.4.7

raw patch · 10 files changed

+140/−80 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• examples/eff.hs +23/−0
• examples/getopt.hs +13/−13
• extensible.cabal +1/−1
• src/Data/Extensible/Bits.hs +28/−1
• src/Data/Extensible/Dictionary.hs +8/−2
• src/Data/Extensible/Field.hs +3/−1
• src/Data/Extensible/GetOpt.hs +44/−17
• src/Data/Extensible/Internal.hs +11/−42
• src/Data/Extensible/Record.hs +3/−3

@@ -1,3 +1,9 @@+0.4.7+-------------------------------------------------+* Made various optimisations to improve the compilation time+* Added trivial instances for `FromBits`+* Generalised the API of `Data.Extensible.GetOpt`+ 0.4.6 ------------------------------------------------- * New module `Data.Extensible.GetOpt`

@@ -0,0 +1,23 @@+{-# LANGUAGE TypeApplications, OverloadedLabels, PolyKinds, DataKinds, ScopedTypeVariables, Rank2Types #-}+import Data.Extensible++import Prelude hiding (readFile)+import Control.Exception+import Data.ByteString (ByteString)++data FileSystem r where+  ReadFile+    :: FilePath+    -> FileSystem (Either SomeException ByteString)++readFile+  :: forall xs+  . (Associate "fs" FileSystem xs+  , Associate "fs_error" (EitherEff SomeException) xs)+  => FilePath+  -> Eff xs ByteString+readFile fp = liftEff #fs (ReadFile fp)+           >>= either (throwEff #fs_error) pure++foo :: forall xs. Associate "fs" FileSystem xs => Eff xs (Either SomeException ByteString)+foo = castEff (runEitherEff @ "fs_error" (readFile "foo") :: Eff '["fs" >: FileSystem] (Either SomeException ByteString))

@@ -1,13 +1,13 @@-{-# LANGUAGE OverloadedLabels, LambdaCase #-}
-import Control.Lens
-import Data.Extensible
-import Data.Extensible.GetOpt
-
-main :: IO ()
-main = withGetOpt opts $ \r _args -> do
-  putStrLn $ "verbose: " ++ show (r ^. #verbose > 0)
-  putStrLn $ "extra: " ++ show (r ^? #extra. folded)
-  where
-    opts = #verbose @= optNoArg "v" ["verbose"] "verbose"
-      <: #extra @= optReqArg "e" ["extra"] "ARG" "extra arguments"
-      <: nil
+{-# LANGUAGE OverloadedLabels, LambdaCase #-}+import Control.Lens+import Data.Extensible+import Data.Extensible.GetOpt++main :: IO ()+main = withGetOpt opts $ \r _args -> do+  putStrLn $ "verbose: " ++ show (r ^. #verbose > 0)+  putStrLn $ "extra: " ++ show (r ^? #extra. folded)+  where+    opts = #verbose @= optNoArg "v" ["verbose"] "verbose"+      <: #extra @= optReqArg "e" ["extra"] "ARG" "extra arguments"+      <: nil

@@ -1,5 +1,5 @@ name:                extensible-version:             0.4.6+version:             0.4.7 synopsis:            Extensible, efficient, optics-friendly data types and effects homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues

@@ -19,6 +19,7 @@ import Data.Extensible.Product import Data.Extensible.Internal (getMemberId) import Data.Extensible.Field+import Data.Extensible.Wrapper import Data.Functor.Identity import Data.Hashable import Data.Ix@@ -27,12 +28,13 @@ import Data.Proxy import Data.Word import Data.Int+import Foreign.Storable (Storable) import GHC.Generics (Generic) import GHC.TypeLits  -- | Bit-vector product. It has similar interface as @(:*)@ but fields are packed into @r@. newtype BitProd r (h :: k -> *) (xs :: [k]) = BitProd { unBitProd :: r }-  deriving (Eq, Ord, Enum, Bounded, Ix, Generic, Hashable)+  deriving (Eq, Ord, Enum, Bounded, Ix, Generic, Hashable, Storable)  instance (Forall (Instance1 Show h) xs, BitFields r h xs) => Show (BitProd r h xs) where   showsPrec d x = showParen (d > 10)@@ -55,6 +57,16 @@   fromBits :: r -> a   toBits :: a -> r +instance Bits r => FromBits r () where+  type BitWidth () = 0+  fromBits _ = ()+  toBits _ = zeroBits++instance Bits r => FromBits r (Proxy a) where+  type BitWidth (Proxy a) = 0+  fromBits _ = Proxy+  toBits _ = zeroBits+ instance FromBits Word64 Word64 where   type BitWidth Word64 = 64   fromBits = id@@ -101,6 +113,18 @@   fromBits = Identity . fromBits   toBits = toBits . runIdentity +instance (FromBits r a, FromBits r b, n ~ (BitWidth a + BitWidth b), n <= BitWidth r, KnownNat n) => FromBits r (a, b) where+  type BitWidth (a, b) = BitWidth a + BitWidth b+  fromBits r = (fromBits (unsafeShiftR r width), fromBits r) where+    width = fromInteger $ natVal (Proxy :: Proxy (BitWidth b))+  toBits (a, b) = unsafeShiftL (toBits a) width .|. toBits b where+    width = fromInteger $ natVal (Proxy :: Proxy (BitWidth b))++instance FromBits r a => FromBits r (Const' a b) where+  type BitWidth (Const' a b) = BitWidth a+  fromBits = Const' . fromBits+  toBits = toBits . getConst'+ instance (Bits r, FromBits r (h (AssocValue x))) => FromBits r (Field h x) where   type BitWidth (Field h x) = BitWidth (h (AssocValue x))   fromBits = Field . fromBits@@ -120,11 +144,13 @@ toBitProd :: forall r h xs. BitFields r h xs => h :* xs -> BitProd r h xs toBitProd p = hfoldrWithIndexFor (Proxy :: Proxy (Instance1 (FromBits r) h))   (\i v f r -> f $! bupdate i r v) id p (BitProd zeroBits)+{-# INLINE toBitProd #-}  -- | Convert a normal extensible record into a bit record. fromBitProd :: forall r h xs. BitFields r h xs => BitProd r h xs -> h :* xs fromBitProd p = htabulateFor (Proxy :: Proxy (Instance1 (FromBits r) h))   $ flip blookup p+{-# INLINE fromBitProd #-}  -- | 'hlookup' for 'BitProd' blookup :: forall x r h xs.@@ -156,6 +182,7 @@     then o     else r (fromInteger (natVal (proxyBitWidth ph m)) + o) (i - 1))   (error "Impossible") 0+{-# INLINE bitOffsetAt #-}  proxyBitWidth :: Proxy h -> proxy x -> Proxy (BitWidth (h x)) proxyBitWidth _ _ = Proxy

@@ -115,7 +115,9 @@   basicUnsafeNew n = fmap MV_Product     $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))     (const $ Comp <$> M.basicUnsafeNew n)+#if MIN_VERSION_vector(0,11,0)   basicInitialize (MV_Product v) = ENUM_EACH(\i -> M.basicInitialize $ hlookupC i v)+#endif   basicUnsafeReplicate n x = fmap MV_Product     $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))     $ \m -> fmap Comp $ M.basicUnsafeReplicate n $ hlookup m x@@ -202,7 +204,6 @@   {-# INLINE basicUnsafeSlice #-}   {-# INLINE basicOverlaps #-}   {-# INLINE basicUnsafeNew #-}-  {-# INLINE basicInitialize #-}   {-# INLINE basicUnsafeReplicate #-}   {-# INLINE basicUnsafeRead #-}   {-# INLINE basicUnsafeWrite #-}@@ -214,7 +215,10 @@   basicUnsafeSlice i n (MV_Identity v) = MV_Identity $ M.basicUnsafeSlice i n v   basicOverlaps (MV_Identity v1) (MV_Identity v2) = M.basicOverlaps v1 v2   basicUnsafeNew n = MV_Identity <$> M.basicUnsafeNew n+#if MIN_VERSION_vector(0,11,0)   basicInitialize (MV_Identity v) = M.basicInitialize v+  {-# INLINE basicInitialize #-}+#endif   basicUnsafeReplicate n (Identity x) = MV_Identity <$> M.basicUnsafeReplicate n x   basicUnsafeRead (MV_Identity v) i = Identity <$> M.basicUnsafeRead v i   basicUnsafeWrite (MV_Identity v) i (Identity x) = M.basicUnsafeWrite v i x@@ -247,7 +251,6 @@   {-# INLINE basicUnsafeSlice #-}   {-# INLINE basicOverlaps #-}   {-# INLINE basicUnsafeNew #-}-  {-# INLINE basicInitialize #-}   {-# INLINE basicUnsafeReplicate #-}   {-# INLINE basicUnsafeRead #-}   {-# INLINE basicUnsafeWrite #-}@@ -259,7 +262,10 @@   basicUnsafeSlice i n (MV_Const v) = MV_Const $ M.basicUnsafeSlice i n v   basicOverlaps (MV_Const v1) (MV_Const v2) = M.basicOverlaps v1 v2   basicUnsafeNew n = MV_Const <$> M.basicUnsafeNew n+#if MIN_VERSION_vector(0,11,0)   basicInitialize (MV_Const v) = M.basicInitialize v+  {-# INLINE basicInitialize #-}+#endif   basicUnsafeReplicate n (Const' x) = MV_Const <$> M.basicUnsafeReplicate n x   basicUnsafeRead (MV_Const v) i = Const' <$> M.basicUnsafeRead v i   basicUnsafeWrite (MV_Const v) i (Const' x) = M.basicUnsafeWrite v i x

@@ -130,7 +130,6 @@   {-# INLINE basicUnsafeSlice #-}   {-# INLINE basicOverlaps #-}   {-# INLINE basicUnsafeNew #-}-  {-# INLINE basicInitialize #-}   {-# INLINE basicUnsafeReplicate #-}   {-# INLINE basicUnsafeRead #-}   {-# INLINE basicUnsafeWrite #-}@@ -142,7 +141,10 @@   basicUnsafeSlice i n (MV_Field v) = MV_Field $ M.basicUnsafeSlice i n v   basicOverlaps (MV_Field v1) (MV_Field v2) = M.basicOverlaps v1 v2   basicUnsafeNew n = MV_Field <$> M.basicUnsafeNew n+#if MIN_VERSION_vector(0,11,0)   basicInitialize (MV_Field v) = M.basicInitialize v+  {-# INLINE basicInitialize #-}+#endif   basicUnsafeReplicate n (Field x) = MV_Field <$> M.basicUnsafeReplicate n x   basicUnsafeRead (MV_Field v) i = Field <$> M.basicUnsafeRead v i   basicUnsafeWrite (MV_Field v) i (Field x) = M.basicUnsafeWrite v i x

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, LambdaCase #-}+{-# LANGUAGE TypeFamilies, LambdaCase, DeriveFunctor, StandaloneDeriving #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.GetOpt@@ -9,9 +9,12 @@ -- -- A wrapper for 'System.Console.GetOpt' ---------------------------------------------------------------------------------module Data.Extensible.GetOpt (OptDescr'(..)+module Data.Extensible.GetOpt (OptionDescr(..)+  , OptDescr'   , optNoArg   , optReqArg+  , optionNoArg+  , optionReqArg   , getOptRecord   , withGetOpt) where @@ -21,6 +24,7 @@ import Data.Extensible.Internal.Rig import Data.Extensible.Product import Data.Extensible.Wrapper+import Data.Functor.Identity import Data.List (foldl') import System.Console.GetOpt import System.Environment@@ -28,10 +32,26 @@ import System.IO  -- | 'OptDescr' with a default-data OptDescr' a = OptDescr' a (OptDescr (a -> a))+data OptionDescr h a = forall s. OptionDescr (s -> h a) !s (OptDescr (s -> s)) -instance Wrapper OptDescr' where-  type Repr OptDescr' a = OptDescr' a+deriving instance Functor h => Functor (OptionDescr h)++supplyOption :: Maybe String -> OptionDescr h a -> OptionDescr h a+supplyOption str od@(OptionDescr k s opt@(Option _ _ arg _)) = case (str, arg) of+  (Just a, ReqArg f _) -> OptionDescr k (f a s) opt+  (Nothing, NoArg f) -> OptionDescr k (f s) opt+  (a, OptArg f _) -> OptionDescr k (f a s) opt+  _ -> od++extendArg :: (Maybe String -> a -> b) -> ArgDescr a -> ArgDescr b+extendArg f (NoArg a) = NoArg $ f Nothing a+extendArg f (ReqArg a ph) = ReqArg (\s -> f (Just s) (a s)) ph+extendArg f (OptArg a ph) = OptArg (f <*> a) ph++type OptDescr' = OptionDescr Identity++instance Wrapper (OptionDescr h) where+  type Repr (OptionDescr h) a = OptionDescr h a   _Wrapper = id  -- | Option without an argument; the result is the total count of this option.@@ -39,33 +59,40 @@     -> [String] -- ^ long option     -> String -- ^ explanation     -> OptDescr' Int-optNoArg ss ls expl = OptDescr' 0 $ Option ss ls (NoArg (+1)) expl+optNoArg = optionNoArg Identity +optionNoArg :: (Int -> h a) -> [Char] -> [String] -> String -> OptionDescr h a+optionNoArg f ss ls expl = OptionDescr f 0 $ Option ss ls (NoArg (+1)) expl+ -- | Option with an argument optReqArg :: [Char] -- ^ short option     -> [String] -- ^ long option     -> String -- ^ placeholder     -> String -- ^ explanation     -> OptDescr' [String]-optReqArg ss ls ph expl = OptDescr' [] $ Option ss ls (ReqArg (:) ph) expl+optReqArg = optionReqArg Identity -getOptRecord :: RecordOf OptDescr' xs -- ^ a record of option descriptors+optionReqArg :: ([String] -> h a) -> [Char] -> [String] -> String -> String -> OptionDescr h a+optionReqArg f ss ls ph expl = OptionDescr f [] $ Option ss ls (ReqArg (:) ph) expl++getOptRecord :: RecordOf (OptionDescr h) xs -- ^ a record of option descriptors     -> [String] -- ^ arguments-    -> (Record xs, [String], [String], String -> String) -- ^ (result, remaining non-options, errors, usageInfo)-getOptRecord descs args = (foldl' (flip id) def fs, rs, es, flip usageInfo updaters) where+    -> (RecordOf h xs, [String], [String], String -> String) -- ^ (result, remaining non-options, errors, usageInfo)+getOptRecord descs args = (result, rs, es, flip usageInfo updaters) where   (fs, rs, es) = getOpt Permute updaters args   updaters = hfoldrWithIndex-      (\i (Field (OptDescr' _ opt)) -> (:)-          $ fmap (\f -> over (pieceAt i) (Field . fmap f . getField)) opt)+      (\i (Field (OptionDescr _ _ (Option ss ls arg expl))) -> (:)+          $ Option ss ls (extendArg (\a _ -> over (pieceAt i) (liftField (supplyOption a))) arg) expl)       [] descs-  def = hmap (\(Field (OptDescr' x _)) -> Field (pure x)) descs+  result = hmap (\(Field (OptionDescr k x _)) -> Field (k x))+      $ foldl' (flip id) descs fs  -- | When there's an error, print it along with the usage info to stderr -- and terminate with 'exitFailure'.-withGetOpt :: MonadIO m => RecordOf OptDescr' xs-  -> (Record xs -> [String] -> m a) -> m a-withGetOpt descs k = getOptRecord descs <$> liftIO getArgs >>= \case+withGetOpt :: MonadIO m => String -> RecordOf (OptionDescr h) xs+  -> (RecordOf h xs -> [String] -> m a) -> m a+withGetOpt nonOptUsage descs k = getOptRecord descs <$> liftIO getArgs >>= \case   (r, xs, [], _) -> k r xs   (_, _, errs, usage) -> liftIO $ do     mapM_ (hPutStrLn stderr) errs-    getProgName >>= die . usage+    getProgName >>= die . usage . (++ (' ' : nonOptUsage))

@@ -48,9 +48,6 @@   , Elaborate   , Elaborated(..)   -- * Miscellaneous-  , Nat(..)-  , KnownPosition(..)-  , Succ   , Head   , Last   , module Data.Type.Equality@@ -70,6 +67,7 @@ import Language.Haskell.TH hiding (Pred) import Data.Bits import Data.Semigroup (Semigroup(..))+import GHC.TypeLits  -- | Generates a 'Membership' that corresponds to the given ordinal (0-origin). mkMembership :: Int -> Q Exp@@ -96,8 +94,8 @@ class Member xs x where   membership :: Membership xs x -instance (Elaborate x (FindType x xs) ~ 'Expecting pos, KnownPosition pos) => Member xs x where-  membership = Membership (theInt (Proxy :: Proxy pos))+instance (Elaborate x (FindType x xs) ~ 'Expecting pos, KnownNat pos) => Member xs x where+  membership = Membership (fromInteger $ natVal (Proxy :: Proxy pos))   {-# INLINE membership #-}  instance Hashable (Membership xs x) where@@ -118,8 +116,8 @@ class Associate k v xs | k xs -> v where   association :: Membership xs (k ':> v) -instance (Elaborate k (FindAssoc k xs) ~ 'Expecting (n ':> v), KnownPosition n) => Associate k v xs where-  association = Membership (theInt (Proxy :: Proxy n))+instance (Elaborate k (FindAssoc 0 k xs) ~ 'Expecting (n ':> v), KnownNat n) => Associate k v xs where+  association = Membership (fromInteger $ natVal (Proxy :: Proxy n))  -- | A readable type search result data Elaborated k v = Expecting v | Missing k | Duplicate k@@ -129,14 +127,10 @@   Elaborate k '[x] = 'Expecting x   Elaborate k xs = 'Duplicate k -type family FindAssoc (key :: k) (xs :: [Assoc k v]) where-  FindAssoc k ((k ':> v) ': xs) = ('Zero ':> v) ': MapSuccKey (FindAssoc k xs)-  FindAssoc k ((k' ':> v) ': xs) = MapSuccKey (FindAssoc k xs)-  FindAssoc k '[] = '[]--type family MapSuccKey (xs :: [Assoc Nat v]) :: [Assoc Nat v] where-  MapSuccKey '[] = '[]-  MapSuccKey ((k ':> x) ': xs) = (Succ k ':> x) ': MapSuccKey xs+type family FindAssoc (n :: Nat) (key :: k) (xs :: [Assoc k v]) where+  FindAssoc n k ((k ':> v) ': xs) = (n ':> v) ': FindAssoc (1 + n) k xs+  FindAssoc n k ((k' ':> v) ': xs) = FindAssoc (1 + n) k xs+  FindAssoc n k '[] = '[]  instance Show (Membership xs x) where   show (Membership n) = "$(mkMembership " ++ show n ++ ")"@@ -185,7 +179,7 @@  -- | FindType types type family FindType (x :: k) (xs :: [k]) :: [Nat] where-  FindType x (x ': xs) = 'Zero ': FindType x xs+  FindType x (x ': xs) = 0 ': FindType x xs   FindType x (y ': ys) = MapSucc (FindType x ys)   FindType x '[] = '[] @@ -193,32 +187,7 @@   Last '[x] = x   Last (x ': xs) = Last xs --- | Type level binary number-data Nat = Zero | DNat Nat | SDNat Nat---- | Converts type naturals into 'Word'.-class KnownPosition n where-  theInt :: proxy n -> Int--instance KnownPosition 'Zero where-  theInt _ = 0-  {-# INLINE theInt #-}--instance KnownPosition n => KnownPosition ('DNat n) where-  theInt _ = theInt (Proxy :: Proxy n) `unsafeShiftL` 1-  {-# INLINE theInt #-}--instance KnownPosition n => KnownPosition ('SDNat n) where-  theInt _ = (theInt (Proxy :: Proxy n) `unsafeShiftL` 1) + 1-  {-# INLINE theInt #-}---- | The successor of the number-type family Succ (x :: Nat) :: Nat where-  Succ 'Zero = 'SDNat 'Zero-  Succ ('DNat n) = 'SDNat n-  Succ ('SDNat n) = 'DNat (Succ n)- -- | Ideally, it will be 'Map Succ' type family MapSucc (xs :: [Nat]) :: [Nat] where   MapSucc '[] = '[]-  MapSucc (x ': xs) = Succ x ': MapSucc xs+  MapSucc (x ': xs) = (1 + x) ': MapSucc xs

@@ -84,11 +84,11 @@             []             ]         , FunD 'recordToList [Clause-            [VarP rec]+            [ConP conName (map VarP newNames)]             (NormalB $ shape2Exp [AppE (ConE 'Field)                 $ AppE (ConE 'Identity)-                $ VarE n `AppE` VarE rec-              | n <- names])+                $ VarE n+              | n <- newNames])             []             ]         ]