NaperianNetCDF (empty) → 0.1.0.0
raw patch · 6 files changed
+248/−0 lines, 6 filesdep +Naperiandep +NaperianExampledep +basesetup-changed
Dependencies added: Naperian, NaperianExample, base, hnetcdf, split, vector
Files
- CHANGELOG.md +5/−0
- Data/Naperian/NetCDF.hs +72/−0
- LICENSE +30/−0
- NaperianNetCDF.cabal +34/−0
- Setup.hs +2/−0
- test/Main.hs +105/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for NaperianExample++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ Data/Naperian/NetCDF.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+++{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeFamilies #-}+++module Data.Naperian.NetCDF () where++import Data.NetCDF.Store+import Naperian+import GHC.TypeNats+import Data.Proxy++import GHC.ForeignPtr+import GHC.Ptr+import Foreign.Storable+import qualified Data.Vector.Storable as SV++import Data.Maybe ( fromJust )+import Data.Foldable ( toList )+import Control.Monad++instance (KnownNat n, Storable e) => Storable (Vector n e) where+ poke p v = zipWithM_ poke qs (toList v)+ where+ qs = map (\i -> plusPtr q (l * i)) [0 .. n - 1]+ n = fromIntegral $ natVal (Proxy :: Proxy n)+ l = sizeOf (undefined :: e)+ q = castPtr p+ peek p = do vs <- mapM peek qs+ return $ fromJust $ fromList vs+ where+ q :: Ptr e+ q = castPtr p+ qs = map (\i -> plusPtr q (l * i)) [0 .. n - 1]+ l = sizeOf (undefined :: e)+ n = fromIntegral $ natVal (Proxy :: Proxy n)+ sizeOf _ = n * sizeOf (undefined :: e)+ where+ n = fromIntegral $ natVal (Proxy :: Proxy n)+ alignment _ = alignment (undefined :: e)++instance NcStore (Hyper '[]) where+ toForeignPtr = fst . SV.unsafeToForeignPtr0 . SV.fromList . elements+ fromForeignPtr p _ = Scalar . head . SV.toList $ SV.unsafeFromForeignPtr0 p 1+ smap = error "smap: NcStore (Hyper '[])"++instance (KnownNat n, Shapely fs, NcStore (Hyper fs)) =>+ NcStore (Hyper ((Vector n) : fs)) where+ type NcStoreExtraCon (Hyper ((Vector n) : fs)) e = NcStoreExtraCon (Hyper fs) (Vector n e)+ toForeignPtr :: forall e . Storable e =>+ Hyper ((Vector n) : fs) e -> ForeignPtr e+ toForeignPtr = fst . SV.unsafeToForeignPtr0 . SV.fromList . elements+ fromForeignPtr :: forall e . (Storable e , NcStoreExtraCon (Hyper fs) (Vector n e)) =>+ ForeignPtr e -> [Int] -> Hyper ((Vector n) : fs) e+ fromForeignPtr p _ = Prism ws+ where+ q :: ForeignPtr (Vector n e)+ q = castForeignPtr p++ ws :: Hyper fs (Vector n e)+ ws = fromForeignPtr q undefined+ smap = error "smap: NcStore (Hyper ((Vector n) : fs))"+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Dominic Steinitz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Dominic Steinitz nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ NaperianNetCDF.cabal view
@@ -0,0 +1,34 @@+cabal-version: 2.4++name: NaperianNetCDF+version: 0.1.0.0+synopsis: Instances of NcStore for hypercuboids++description: This allows [NetCDF](https://en.wikipedia.org/wiki/NetCDF) data to be read and written into [hypercuboids](http://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/apl-extabs.pdf) e.g. values with type @Hyper '[Vector 5, Vector 2, Vector 3] Int@ such as @\<\<\<1,2,3,4,5>, \<6,7,8,9,10>>, \<\<11,12,13,14,15>, \<16,17,18,19,20>>, \<\<21,22,23,24,25>, \<26,27,28,29,30>>>@+bug-reports: https://github.com/idontgetoutmuch/NaperianNetCDF/issues+license: BSD-3-Clause+license-file: LICENSE+author: Dominic Steinitz+maintainer: dominic@steinitz.org+copyright: Dominic Steinitz+category: Math+extra-source-files: CHANGELOG.md++library+ exposed-modules: Data.Naperian.NetCDF+ build-depends: base >=4.12 && <4.13,+ Naperian,+ hnetcdf,+ vector+ default-language: Haskell2010++executable Main+ main-is: Main.hs+ other-extensions: TypeOperators+ build-depends: base ^>=4.12.0.0,+ NaperianExample,+ Naperian,+ hnetcdf,+ split+ hs-source-dirs: test+ default-language: Haskell2010
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ test/Main.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeFamilies #-}++module Main (main) where++import Naperian+import Data.Naperian.NetCDF ()+import GHC.ForeignPtr+import Data.NetCDF.Store+import Data.Maybe ( fromJust )+import Data.Proxy+import GHC.TypeLits+import Data.List.Split+import Data.Foldable ( toList )+++class ListLike fs where+ toListLike :: fs e -> [e]+ unToListLike :: [e] -> fs e++instance ListLike (Hyper '[]) where+ toListLike (Scalar c) = [c]+ unToListLike [c] = Scalar c+ unToListLike cs = error $ "ToListLike: wrong length = " ++ show (Prelude.length cs)++instance (KnownNat n, ListLike (Hyper fs), Shapely fs) =>+ ListLike (Hyper ((Vector n) : fs)) where+ toListLike (Prism c) = concat $ toListLike $ fmap toList c+ unToListLike :: forall e . [e] -> Hyper ((Vector n) : fs) e+ unToListLike cs = Prism $ unToListLike us+ where+ us :: [Vector n e]+ us = map (fromJust . fromList) $+ chunksOf n cs++ n = fromIntegral $ natVal (Proxy :: Proxy n)++u :: Matrix 2 5 Int+u = [ [ 1, 2, 3, 4, 5 ]+ , [ 6, 7, 8, 9, 10 ]+ ]++v4 :: Hyper '[Vector 5, Vector 2] Int+v4 = Prism (Prism (Scalar u))++v5 :: Hyper '[Vector 5, Vector 2, Vector 3] Int+v5 = Prism (Prism (Prism (Scalar a)))++a :: Vector 3 (Vector 2 (Vector 5 Int))+a = fromJust $ fromList $ [b, b1, b2]++b :: Vector 2 (Vector 5 Int)+b = [ [ 1, 2, 3, 4, 5 ]+ , [ 6, 7, 8, 9, 10 ]+ ]++b1 :: Vector 2 (Vector 5 Int)+b1 = [ [ 11, 12, 13, 14, 15 ]+ , [ 16, 17, 18, 19, 20 ]+ ]++b2 :: Vector 2 (Vector 5 Int)+b2 = [ [ 21, 22, 23, 24, 25 ]+ , [ 26, 27, 28, 29, 30 ]+ ]+++roundTrip :: Hyper '[Vector 5, Vector 2, Vector 3] Int ->+ Hyper '[Vector 5, Vector 2, Vector 3] Int+roundTrip = unToListLike . toListLike+++main :: IO ()+main = do+ print v5+ print $ roundTrip v5+ let scalarPi :: Hyper '[] Double+ scalarPi = Scalar pi+ let fpPi :: ForeignPtr Double+ fpPi = toForeignPtr scalarPi+ let roundTripPi :: Hyper '[] Double+ roundTripPi = fromForeignPtr fpPi undefined+ putStrLn $ show (point scalarPi == point roundTripPi)+ let foo = toForeignPtr $ Prism $ Scalar ([ 1, 2, 3 ] :: Vector 3 Int)+ bar :: Hyper '[Vector 3] Int+ bar = fromForeignPtr foo undefined+ putStrLn $ show bar+ let foo2 = toForeignPtr v4+ bar2 :: Hyper '[Vector 5, Vector 2] Int+ bar2 = fromForeignPtr foo2 undefined+ putStrLn $ show v4+ putStrLn $ show bar2+ let foo3 = toForeignPtr v5+ bar3 :: Hyper '[Vector 5, Vector 2, Vector 3] Int+ bar3 = fromForeignPtr foo3 undefined+ putStrLn $ show v5+ putStrLn $ show bar3