diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright 2015 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,44 @@ +#!/usr/bin/env runhaskell +\begin{code} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List ( nub ) +import Data.Version ( showVersion ) +import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) +import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Verbosity ( Verbosity ) +import System.FilePath ( () ) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + } + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys + +\end{code} diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,4 @@ +0.0.1 + +* Initial version. + diff --git a/foscam-filename.cabal b/foscam-filename.cabal new file mode 100644 --- /dev/null +++ b/foscam-filename.cabal @@ -0,0 +1,84 @@ +name: foscam-filename +version: 0.0.1 +license: BSD3 +license-file: LICENSE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +copyright: Copyright (C) 2015 Tony Morris +synopsis: Foscam File format +category: Data +description: + Foscam File format + +homepage: https://github.com/tonymorris/foscam-filename +bug-reports: https://github.com/tonymorris/foscam-filename +cabal-version: >= 1.10 +build-type: Custom +extra-source-files: changelog + +source-repository head + type: git + location: git@github.com:tonymorris/foscam-filename.git + +flag small_base + description: Choose the new, split-up base package. + +library + default-language: + Haskell2010 + + build-depends: + base >= 4 && < 5 + , semigroups >= 0.17 && < 0.19 + , semigroupoids >= 5.0 && < 5.1 + , bifunctors >= 5 && < 6.0 + , lens >= 4.0 && < 5 + , parsers >= 0.12 && < 0.13 + , digit >= 0.1.1 && < 0.2 + + ghc-options: + -Wall + + default-extensions: + NoImplicitPrelude + + hs-source-dirs: + src + + exposed-modules: + Data.Foscam.File + Data.Foscam.File.Alias + Data.Foscam.File.AliasCharacter + Data.Foscam.File.Date + Data.Foscam.File.DeviceId + Data.Foscam.File.DeviceIdCharacter + Data.Foscam.File.Internal + Data.Foscam.File.Filename + Data.Foscam.File.ImageId + Data.Foscam.File.Time + +test-suite doctests + type: + exitcode-stdio-1.0 + + main-is: + doctests.hs + + default-language: + Haskell2010 + + build-depends: + base >= 4 && < 5 + , doctest >= 0.9.7 && < 0.11 + , filepath >= 1.3 && < 1.5 + , directory >= 1.1 && < 1.3 + , QuickCheck >= 2.0 && < 3.0 + , template-haskell >= 2.8 && < 3.0 + , parsec >= 3.1 && < 4.0 + + ghc-options: + -Wall + -threaded + + hs-source-dirs: + test diff --git a/src/Data/Foscam/File.hs b/src/Data/Foscam/File.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} + +module Data.Foscam.File( + module F +) where + +import Data.Foscam.File.Alias as F +import Data.Foscam.File.AliasCharacter as F +import Data.Foscam.File.Date as F +import Data.Foscam.File.DeviceIdCharacter as F +import Data.Foscam.File.DeviceId as F +import Data.Foscam.File.ImageId as F +import Data.Foscam.File.Filename as F +import Data.Foscam.File.Time as F diff --git a/src/Data/Foscam/File/Alias.hs b/src/Data/Foscam/File/Alias.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File/Alias.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} + +module Data.Foscam.File.Alias( + Alias(..) +, AsAlias(..) +, AsAliasHead(..) +, AsAliasTail(..) +, alias +) where + +import Control.Applicative(Applicative((<*>)), (<$>)) +import Control.Category(Category(id)) +import Control.Lens(Optic', Choice, Cons(_Cons), prism', lens, (^?), (#)) +import Control.Monad(Monad) +import Data.Eq(Eq) +import Data.Foscam.File.AliasCharacter(AliasCharacter, AsAliasCharacter(_AliasCharacter), aliasCharacter) +import Data.Functor(Functor) +import Data.Maybe(Maybe(Nothing, Just)) +import Data.Ord(Ord) +import Data.String(String) +import Data.Traversable(traverse) +import Prelude(Show) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators(many, (), try) + +-- $setup +-- >>> import Text.Parsec + +data Alias = + Alias + AliasCharacter + [AliasCharacter] + deriving (Eq, Ord, Show) + +class AsAlias p f s where + _Alias :: + Optic' p f s Alias + +instance AsAlias p f Alias where + _Alias = + id + +instance (Choice p, Applicative f) => AsAlias p f String where + _Alias = + prism' + (\(Alias h t) -> (_AliasCharacter #) <$> (h:t)) + (\s -> case s of + [] -> + Nothing + h:t -> + let ch = (^? _AliasCharacter) + in Alias <$> ch h <*> traverse ch t) + +instance Cons Alias Alias AliasCharacter AliasCharacter where + _Cons = + prism' + (\(h, Alias h' t) -> Alias h (h':t)) + (\(Alias h t) -> case t of + [] -> + Nothing + u:v -> + Just (h, Alias u v)) + +class AsAliasHead p f s where + _AliasHead :: + Optic' p f s AliasCharacter + +instance AsAliasHead p f AliasCharacter where + _AliasHead = + id + +instance (p ~ (->), Functor f) => AsAliasHead p f Alias where + _AliasHead = + lens + (\(Alias h _) -> h) + (\(Alias _ t) h -> Alias h t) + +class AsAliasTail p f s where + _AliasTail :: + Optic' p f s [AliasCharacter] + +instance AsAliasTail p f [AliasCharacter] where + _AliasTail = + id + +instance (p ~ (->), Functor f) => AsAliasTail p f Alias where + _AliasTail = + lens + (\(Alias _ t) -> t) + (\(Alias h _) t -> Alias h t) + +-- | +-- +-- >>> parse alias "test" "abcdef" +-- Right (Alias (AliasCharacter 'a') [AliasCharacter 'b',AliasCharacter 'c',AliasCharacter 'd',AliasCharacter 'e',AliasCharacter 'f']) +-- +-- >>> parse alias "test" "abc123" +-- Right (Alias (AliasCharacter 'a') [AliasCharacter 'b',AliasCharacter 'c',AliasCharacter '1',AliasCharacter '2',AliasCharacter '3']) +-- +-- >>> parse alias "test" "abc*123" +-- Right (Alias (AliasCharacter 'a') [AliasCharacter 'b',AliasCharacter 'c']) +-- +-- >>> parse alias "test" "abc*" +-- Right (Alias (AliasCharacter 'a') [AliasCharacter 'b',AliasCharacter 'c']) +-- +-- >>> parse alias "test" "" +-- Left "test" (line 1, column 1): +-- unexpected end of input +-- expecting alias +alias :: + (Monad f, CharParsing f) => + f Alias +alias = + let a = try aliasCharacter + in Alias <$> a <*> many a "alias" diff --git a/src/Data/Foscam/File/AliasCharacter.hs b/src/Data/Foscam/File/AliasCharacter.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File/AliasCharacter.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Foscam.File.AliasCharacter ( + AliasCharacter +, AsAliasCharacter(..) +, aliasCharacter +) where + +import Control.Applicative(Applicative(pure), (<$>)) +import Control.Category(Category((.), id)) +import Control.Lens(Optic', Choice, prism') +import Control.Monad(Monad(fail)) +import Data.Char(Char) +import Data.Eq(Eq) +import Data.Foscam.File.Internal(boolj, charP) +import Data.List((++), notElem) +import Data.Ord(Ord) +import Prelude(Show) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Text.Parsec + +newtype AliasCharacter = + AliasCharacter Char + deriving (Eq, Ord, Show) + +class AsAliasCharacter p f s where + _AliasCharacter :: + Optic' p f s AliasCharacter + +instance AsAliasCharacter p f AliasCharacter where + _AliasCharacter = + id + +instance (Choice p, Applicative f) => AsAliasCharacter p f Char where + _AliasCharacter = + prism' + (\(AliasCharacter c) -> c) + ((AliasCharacter <$>) . boolj (`notElem` ['/', ':', '*', '?', '"', '<', '>', '(', ')'])) + +-- todo: _1 to _12 ?? + +-- | +-- +-- >>> parse aliasCharacter "test" "2062" +-- Right (AliasCharacter '2') +-- +-- >>> parse aliasCharacter "test" "2" +-- Right (AliasCharacter '2') +-- +-- >>> parse aliasCharacter "test" "abc" +-- Right (AliasCharacter 'a') +-- +-- >>> parse aliasCharacter "test" "*" +-- Left "test" (line 1, column 2): +-- not an alias character: * +-- +-- >>> parse aliasCharacter "test" "<" +-- Left "test" (line 1, column 2): +-- not an alias character: < +-- +-- >>> parse aliasCharacter "test" "" +-- Left "test" (line 1, column 1): +-- unexpected end of input +-- expecting alias character +aliasCharacter :: + (Monad f, CharParsing f) => + f AliasCharacter +aliasCharacter = + charP (fail . ("not an alias character: " ++) . pure) _AliasCharacter "alias character" + diff --git a/src/Data/Foscam/File/Date.hs b/src/Data/Foscam/File/Date.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File/Date.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Foscam.File.Date( + Date(..) +, AsDate(..) +, date +) where + +import Control.Applicative(Applicative((<*>)), (<$>)) +import Control.Category(Category(id)) +import Control.Lens(Optic', Choice, prism', (^?), (#)) +import Control.Monad(Monad) +import Data.Digit(Digit, digitC) +import Data.Eq(Eq) +import Data.Foscam.File.Internal(digitCharacter) +import Data.Maybe(Maybe(Nothing)) +import Data.Ord(Ord) +import Data.String(String) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators(()) +import Prelude(Show) + +-- $setup +-- >>> import Text.Parsec + +data Date = + Date + Digit + Digit + Digit + Digit + Digit + Digit + Digit + Digit + deriving (Eq, Ord, Show) + +class AsDate p f s where + _Date :: + Optic' p f s Date + +instance AsDate p f Date where + _Date = + id + +instance (Choice p, Applicative f) => AsDate p f String where + _Date = + prism' + (\(Date d01 d02 d03 d04 d05 d06 d07 d08) -> (digitC #) <$> [d01, d02, d03, d04, d05, d06, d07, d08]) + (\s -> case s of + [c01, c02, c03, c04, c05, c06, c07, c08] -> + let f = (^? digitC) + in Date <$> + f c01 <*> + f c02 <*> + f c03 <*> + f c04 <*> + f c05 <*> + f c06 <*> + f c07 <*> + f c08 + _ -> + Nothing) + +-- | +-- +-- >>> parse date "test" "20140508" +-- Right (Date 2 0 1 4 0 5 0 8) +-- +-- >>> parse date "test" "20140508abc" +-- Right (Date 2 0 1 4 0 5 0 8) +-- +-- >>> parse date "test" "201405" +-- Left "test" (line 1, column 7): +-- unexpected end of input +-- expecting digit +-- +-- >>> parse date "test" "201405a9" +-- Left "test" (line 1, column 8): +-- not a digit: a +-- +-- >>> parse date "test" "" +-- Left "test" (line 1, column 1): +-- unexpected end of input +-- expecting date +date :: + (Monad f, CharParsing f) => + f Date +date = + Date <$> + digitCharacter <*> + digitCharacter <*> + digitCharacter <*> + digitCharacter <*> + digitCharacter <*> + digitCharacter <*> + digitCharacter <*> + digitCharacter "date" diff --git a/src/Data/Foscam/File/DeviceId.hs b/src/Data/Foscam/File/DeviceId.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File/DeviceId.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Foscam.File.DeviceId( + DeviceId(..) +, AsDeviceId(..) +, deviceId +) where + +import Control.Applicative(Applicative((<*>)), (<$>)) +import Control.Category(id) +import Control.Lens(Optic', Choice, prism', (^?), ( # )) +import Control.Monad(Monad) +import Data.Eq(Eq) +import Data.Foscam.File.DeviceIdCharacter +import Data.Functor(fmap) +import Data.Maybe(Maybe(Nothing)) +import Data.Ord(Ord) +import Data.String(String) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators(()) +import Prelude(Show) + + +-- $setup +-- >>> import Text.Parsec + +data DeviceId = + DeviceId + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + DeviceIdCharacter + deriving (Eq, Ord, Show) + +class AsDeviceId p f s where + _DeviceId :: + Optic' p f s DeviceId + +instance AsDeviceId p f DeviceId where + _DeviceId = + id + +instance (Choice p, Applicative f) => AsDeviceId p f String where + _DeviceId = + prism' + (\(DeviceId d01 d02 d03 d04 d05 d06 d07 d08 d09 d10 d11 d12) -> fmap (_DeviceIdCharacter #) [d01, d02, d03, d04, d05, d06, d07, d08, d09, d10, d11, d12]) + (\s -> case s of + [c01, c02, c03, c04, c05, c06, c07, c08, c09, c10, c11, c12] -> + let f = (^? _DeviceIdCharacter) + in DeviceId <$> + f c01 <*> + f c02 <*> + f c03 <*> + f c04 <*> + f c05 <*> + f c06 <*> + f c07 <*> + f c08 <*> + f c09 <*> + f c10 <*> + f c11 <*> + f c12 + _ -> + Nothing) + +-- | +-- +-- >>> parse deviceId "test" "AB0934233DEF" +-- Right (DeviceId (DeviceIdCharacter 'A') (DeviceIdCharacter 'B') (DeviceIdCharacter '0') (DeviceIdCharacter '9') (DeviceIdCharacter '3') (DeviceIdCharacter '4') (DeviceIdCharacter '2') (DeviceIdCharacter '3') (DeviceIdCharacter '3') (DeviceIdCharacter 'D') (DeviceIdCharacter 'E') (DeviceIdCharacter 'F')) +-- +-- >>> parse deviceId "test" "AB0934233DEFabc" +-- Right (DeviceId (DeviceIdCharacter 'A') (DeviceIdCharacter 'B') (DeviceIdCharacter '0') (DeviceIdCharacter '9') (DeviceIdCharacter '3') (DeviceIdCharacter '4') (DeviceIdCharacter '2') (DeviceIdCharacter '3') (DeviceIdCharacter '3') (DeviceIdCharacter 'D') (DeviceIdCharacter 'E') (DeviceIdCharacter 'F')) +-- +-- >>> parse deviceId "test" "AB0934233DX" +-- Left "test" (line 1, column 12): +-- not a device ID character: X +-- +-- >>> parse deviceId "test" "AB0934233DEf" +-- Left "test" (line 1, column 13): +-- not a device ID character: f +-- +-- >>> parse deviceId "test" "" +-- Left "test" (line 1, column 1): +-- unexpected end of input +-- expecting device ID +deviceId :: + (Monad f, CharParsing f) => + f DeviceId +deviceId = + DeviceId <$> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter <*> + deviceIdCharacter "device ID" diff --git a/src/Data/Foscam/File/DeviceIdCharacter.hs b/src/Data/Foscam/File/DeviceIdCharacter.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File/DeviceIdCharacter.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Foscam.File.DeviceIdCharacter( + DeviceIdCharacter +, AsDeviceIdCharacter(..) +, deviceIdCharacter +) where + +import Control.Applicative(Applicative(pure)) +import Control.Category(id, (.)) +import Control.Lens(Optic', Choice, prism') +import Control.Monad(Monad(fail)) +import Data.Char(Char) +import Data.Eq(Eq) +import Data.Functor(fmap) +import Data.Foscam.File.Internal(boolj, charP) +import Data.List(elem, (++)) +import Data.Ord(Ord) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators(()) +import Prelude(Show) + + +-- $setup +-- >>> import Text.Parsec + +newtype DeviceIdCharacter = + DeviceIdCharacter Char + deriving (Eq, Ord, Show) + +class AsDeviceIdCharacter p f s where + _DeviceIdCharacter :: + Optic' p f s DeviceIdCharacter + +instance AsDeviceIdCharacter p f DeviceIdCharacter where + _DeviceIdCharacter = + id + +instance (Choice p, Applicative f) => AsDeviceIdCharacter p f Char where + _DeviceIdCharacter = + prism' + (\(DeviceIdCharacter c) -> c) + (fmap DeviceIdCharacter . boolj (`elem` (['A'..'F'] ++ ['0'..'9']))) + +-- | +-- +-- >>> parse deviceIdCharacter "test" "A" +-- Right (DeviceIdCharacter 'A') +-- +-- >>> parse deviceIdCharacter "test" "0" +-- Right (DeviceIdCharacter '0') +-- +-- >>> parse deviceIdCharacter "test" "0abc" +-- Right (DeviceIdCharacter '0') +-- +-- >>> parse deviceIdCharacter "test" "a" +-- Left "test" (line 1, column 2): +-- not a device ID character: a +-- +-- >>> parse deviceIdCharacter "test" "G" +-- Left "test" (line 1, column 2): +-- not a device ID character: G +-- +-- >>> parse deviceIdCharacter "test" "" +-- Left "test" (line 1, column 1): +-- unexpected end of input +-- expecting device ID character +deviceIdCharacter :: + (Monad f, CharParsing f) => + f DeviceIdCharacter +deviceIdCharacter = + charP (fail . ("not a device ID character: " ++) . pure) _DeviceIdCharacter "device ID character" diff --git a/src/Data/Foscam/File/Filename.hs b/src/Data/Foscam/File/Filename.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File/Filename.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} + +module Data.Foscam.File.Filename( + Filename(..) +, AsFilename(..) +, filename +) where + +import Control.Applicative(Applicative((<*>)), (<*), (<$>)) +import Control.Category(id) +import Control.Lens(Optic', lens) +import Control.Monad(Monad) +import Data.Digit(Digit) +import Data.Eq(Eq) +import Data.Foscam.File.Internal(digitCharacter) +import Data.Foscam.File.Alias(AsAlias(_Alias), Alias, alias) +import Data.Foscam.File.Date(AsDate(_Date), Date, date) +import Data.Foscam.File.DeviceId(AsDeviceId(_DeviceId), DeviceId, deviceId) +import Data.Foscam.File.ImageId(AsImageId(_ImageId), ImageId, imageId) +import Data.Foscam.File.Time(AsTime(_Time), Time, time) +import Data.Functor(Functor) +import Data.Ord(Ord) +import Text.Parser.Char(CharParsing, char, string) +import Text.Parser.Combinators(()) +import Prelude(Show) + +-- $setup +-- >>> import Text.Parsec + +data Filename = + Filename + DeviceId + Alias + Digit + Date + Time + ImageId + deriving (Eq, Ord, Show) + +class AsFilename p f s where + _Filename :: + Optic' p f s Filename + +instance AsFilename p f Filename where + _Filename = + id + +instance (p ~ (->), Functor f) => AsDeviceId p f Filename where + _DeviceId = + lens + (\(Filename i _ _ _ _ _) -> i) + (\(Filename _ a x d t m) i -> Filename i a x d t m) + +instance (p ~ (->), Functor f) => AsAlias p f Filename where + _Alias = + lens + (\(Filename _ a _ _ _ _) -> a) + (\(Filename i _ x d t m) a -> Filename i a x d t m) + +instance (p ~ (->), Functor f) => AsDate p f Filename where + _Date = + lens + (\(Filename _ _ _ d _ _) -> d) + (\(Filename i a x _ t m) d -> Filename i a x d t m) + +instance (p ~ (->), Functor f) => AsTime p f Filename where + _Time = + lens + (\(Filename _ _ _ _ t _) -> t) + (\(Filename i a x d _ m) t -> Filename i a x d t m) + +instance (p ~ (->), Functor f) => AsImageId p f Filename where + _ImageId = + lens + (\(Filename _ _ _ _ _ m) -> m) + (\(Filename i a x d t _) m -> Filename i a x d t m) + +-- | +-- +-- >>> parse Filename "test" "00626E44C831(house)_1_20150209134121_2629.jpg" +-- Right (Filename (DeviceId (DeviceIdCharacter '0') (DeviceIdCharacter '0') (DeviceIdCharacter '6') (DeviceIdCharacter '2') (DeviceIdCharacter '6') (DeviceIdCharacter 'E') (DeviceIdCharacter '4') (DeviceIdCharacter '4') (DeviceIdCharacter 'C') (DeviceIdCharacter '8') (DeviceIdCharacter '3') (DeviceIdCharacter '1')) (Alias (AliasCharacter 'h') [AliasCharacter 'o',AliasCharacter 'u',AliasCharacter 's',AliasCharacter 'e']) 1 (Date 2 0 1 5 0 2 0 9) (Time 1 3 4 1 2 1) (ImageId 2 [6,2,9])) +-- +-- >>> parse Filename "test" "00626E44C829(garage)_1_20140313234556_2660.jpg" +-- Right (Filename (DeviceId (DeviceIdCharacter '0') (DeviceIdCharacter '0') (DeviceIdCharacter '6') (DeviceIdCharacter '2') (DeviceIdCharacter '6') (DeviceIdCharacter 'E') (DeviceIdCharacter '4') (DeviceIdCharacter '4') (DeviceIdCharacter 'C') (DeviceIdCharacter '8') (DeviceIdCharacter '2') (DeviceIdCharacter '9')) (Alias (AliasCharacter 'g') [AliasCharacter 'a',AliasCharacter 'r',AliasCharacter 'a',AliasCharacter 'g',AliasCharacter 'e']) 1 (Date 2 0 1 4 0 3 1 3) (Time 2 3 4 5 5 6) (ImageId 2 [6,6,0])) +-- +-- >>> parse Filename "test" "00626E44C82x(garage)_1_20140313234556_2660.jpg" +-- Left "test" (line 1, column 13): +-- not a device ID character: x +-- +-- >>> parse Filename "test" "00626E44C829(gara*ge)_1_20140313234556_2660.jpg" +-- Left "test" (line 1, column 19): +-- not an alias character: * +-- +-- >>> parse Filename "test" "00626E44C829(garage) 1_20140313234556_2660.jpg" +-- Left "test" (line 1, column 20): +-- unexpected " " +-- expecting ")_" +-- +-- >>> parse Filename "test" "00626E44C829(garage)_x_20140313234556_2660.jpg" +-- Left "test" (line 1, column 23): +-- not a digit: x +-- +-- >>> parse Filename "test" "00626E44C829(garage)_1 20140313234556_2660.jpg" +-- Left "test" (line 1, column 23): +-- unexpected " " +-- expecting "_" +-- +-- >>> parse Filename "test" "00626E44C829(garage)_1_x0140313234556_2660.jpg" +-- Left "test" (line 1, column 25): +-- not a digit: x +filename :: + (Monad f, CharParsing f) => + f Filename +filename = + Filename <$> + deviceId <* + char '(' <*> + alias <* + string ")_" <*> + digitCharacter <* + char '_' <*> + date <*> + time <* + char '_' <*> + imageId <* + string ".jpg" "file" diff --git a/src/Data/Foscam/File/ImageId.hs b/src/Data/Foscam/File/ImageId.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File/ImageId.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} + +module Data.Foscam.File.ImageId( + ImageId(..) +, AsImageId(..) +, imageId +) where + +import Control.Applicative(Applicative((<*>)), (<$>)) +import Control.Category(id) +import Control.Lens(Cons(_Cons), Optic', Choice, prism', lens, (^?), ( # )) +import Control.Monad(Monad) +import Data.Digit(Digit, digitC) +import Data.Eq(Eq) +import Data.Foscam.File.Internal(digitCharacter) +import Data.Functor(Functor) +import Data.Maybe(Maybe(Nothing, Just)) +import Data.Ord(Ord) +import Data.String(String) +import Data.Traversable(traverse) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators((), try, many) +import Prelude(Show) + +-- $setup +-- >>> import Text.Parsec + +data ImageId = + ImageId + Digit + [Digit] + deriving (Eq, Ord, Show) + +class AsImageId p f s where + _ImageId :: + Optic' p f s ImageId + +instance AsImageId p f ImageId where + _ImageId = + id + +instance (Choice p, Applicative f) => AsImageId p f String where + _ImageId = + prism' + (\(ImageId h t) -> (digitC #) <$> (h:t)) + (\s -> case s of + [] -> + Nothing + h:t -> + let ch = (^? digitC) + in ImageId <$> ch h <*> traverse ch t) + +instance Cons ImageId ImageId Digit Digit where + _Cons = + prism' + (\(h, ImageId h' t) -> ImageId h (h':t)) + (\(ImageId h t) -> case t of + [] -> + Nothing + u:v -> + Just (h, ImageId u v)) + +class AsImageIdHead p f s where + _ImageIdHead :: + Optic' p f s Digit + +instance AsImageIdHead p f Digit where + _ImageIdHead = + id + +instance (p ~ (->), Functor f) => AsImageIdHead p f ImageId where + _ImageIdHead = + lens + (\(ImageId h _) -> h) + (\(ImageId _ t) h -> ImageId h t) + +class AsImageIdTail p f s where + _ImageIdTail :: + Optic' p f s [Digit] + +instance AsImageIdTail p f [Digit] where + _ImageIdTail = + id + +instance (p ~ (->), Functor f) => AsImageIdTail p f ImageId where + _ImageIdTail = + lens + (\(ImageId _ t) -> t) + (\(ImageId h _) t -> ImageId h t) + +-- | +-- +-- >>> parse imageId "test" "2062" +-- Right (ImageId 2 [0,6,2]) +-- +-- >>> parse imageId "test" "2" +-- Right (ImageId 2 []) +-- +-- >>> parse imageId "test" "a" +-- Left "test" (line 1, column 2): +-- expecting image ID +-- not a digit: a +-- +-- >>> parse imageId "test" "" +-- Left "test" (line 1, column 1): +-- unexpected end of input +-- expecting image ID +imageId :: + (Monad f, CharParsing f) => + f ImageId +imageId = + let i = try digitCharacter + in ImageId <$> i <*> many i "image ID" diff --git a/src/Data/Foscam/File/Internal.hs b/src/Data/Foscam/File/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File/Internal.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Foscam.File.Internal( + charP +, digitCharacter +, boolj +) where + +import Control.Applicative(pure) +import Control.Category((.)) +import Control.Monad(Monad((>>=), fail)) +import Data.Bool(bool, Bool) +import Data.Char(Char) +import Data.Digit(Digit, digitC) +import Data.Maybe(Maybe(Nothing, Just), maybe) +import Data.Monoid(First, (<>)) +import Control.Lens(Getting, (^?)) +import Text.Parser.Char(CharParsing, anyChar) +import Text.Parser.Combinators(()) + +charP :: + (Monad f, CharParsing f) => + (Char -> f a) + -> Getting (First a) Char a + -> f a +charP fl p = + anyChar >>= \c -> maybe (fl c) pure (c ^? p) + +digitCharacter :: + (Monad f, CharParsing f) => + f Digit +digitCharacter = + charP (fail . ("not a digit: " <>) . pure) digitC "digit" + +boolj :: + (a -> Bool) + -> a + -> Maybe a +boolj p x = + bool Nothing (Just x) (p x) diff --git a/src/Data/Foscam/File/Time.hs b/src/Data/Foscam/File/Time.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foscam/File/Time.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Foscam.File.Time( + Time(..) +, AsTime(..) +, time +) where + +import Control.Applicative(Applicative((<*>)), (<$>)) +import Control.Category(id) +import Control.Lens(Optic', Choice, prism', (^?), ( # )) +import Control.Monad(Monad) +import Data.Digit(Digit, digitC) +import Data.Eq(Eq) +import Data.Foscam.File.Internal(digitCharacter) +import Data.Maybe(Maybe(Nothing)) +import Data.Ord(Ord) +import Data.String(String) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators(()) +import Prelude(Show) + +-- $setup +-- >>> import Text.Parsec + +data Time = + Time + Digit + Digit + Digit + Digit + Digit + Digit + deriving (Eq, Ord, Show) + +class AsTime p f s where + _Time :: + Optic' p f s Time + +instance AsTime p f Time where + _Time = + id + +instance (Choice p, Applicative f) => AsTime p f String where + _Time = + prism' + (\(Time d01 d02 d03 d04 d05 d06) -> (digitC #) <$> [d01, d02, d03, d04, d05, d06]) + (\s -> case s of + [c01, c02, c03, c04, c05, c06] -> + let f = (^? digitC) + in Time <$> + f c01 <*> + f c02 <*> + f c03 <*> + f c04 <*> + f c05 <*> + f c06 + _ -> + Nothing) + +-- | +-- +-- >>> parse time "test" "134122" +-- Right (Time 1 3 4 1 2 2) +-- +-- >>> parse time "test" "134122abc" +-- Right (Time 1 3 4 1 2 2) +-- +-- >>> parse time "test" "1341" +-- Left "test" (line 1, column 5): +-- unexpected end of input +-- expecting digit +time :: + (Monad f, CharParsing f) => + f Time +time = + Time <$> + digitCharacter <*> + digitCharacter <*> + digitCharacter <*> + digitCharacter <*> + digitCharacter <*> + digitCharacter "time" diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,85 @@ +module Main where + +import Control.Applicative +import Prelude +import Build_doctests (deps) +import Control.Monad +import Data.List +import Data.Monoid +import System.Directory +import System.FilePath +import System.IO +import Test.DocTest + +main :: + IO () +main = + getSources >>= \sources -> + forM_ (preferredOrderFirst sources) $ \source -> do + hPutStrLn stderr $ "Testing " <> source + doctest $ + "-isrc" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : "-hide-all-packages" + : map ("-package="++) deps ++ [source] + +sourceDirectories :: + [FilePath] +sourceDirectories = + [ + "src" + ] + +preferredOrderFirst :: [FilePath] -> [FilePath] +preferredOrderFirst sources = + filter (`elem` sources ) preferredOrder + <> filter (`notElem` preferredOrder) sources + +-- If you find the tests are running slowly. +-- Comment out the Modules you have completed +-- in the list below. +preferredOrder :: [String] +preferredOrder = map (\f -> "src/Course" f <.> "hs") [ + "List" + , "Functor" + , "Apply" + , "Applicative" + , "Bind" + , "Monad" + , "FileIO" + , "State" + , "StateT" + , "Extend" + , "Comonad" + , "Compose" + , "Traversable" + , "ListZipper" + , "Parser" + , "MoreParser" + , "JsonParser" + , "Interactive" + , "Anagrams" + , "FastAnagrams" + , "Cheque" + ] + +isSourceFile :: + FilePath + -> Bool +isSourceFile p = + and [takeFileName p /= "Setup.hs", isSuffixOf ".hs" p] + +getSources :: IO [FilePath] +getSources = + liftM (filter isSourceFile . concat) (mapM go sourceDirectories) + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c