Permalink
Browse files

init

  • Loading branch information...
0 parents commit 9f6e95c639babc7374607ac4df8d26b031b068d4 @nfjinjing committed Jun 10, 2011
12 .gitignore
@@ -0,0 +1,12 @@
+*.swp
+*.swo
+*.o
+*.hi
+*.exe
+
+
+manifest
+.nemesis
+
+
+/dist
31 LICENSE
@@ -0,0 +1,31 @@
+Copyright (c) 2011, Jinjing Wang
+
+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 Jinjing Wang 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.
21 Nemesis
@@ -0,0 +1,21 @@
+nemesis = do
+
+ clean
+ [ "**/*.hi"
+ , "**/*.o"
+ , "manifest"
+ ]
+
+ desc "prepare cabal dist"
+ task "dist" - do
+ sh "cabal clean"
+ sh "cabal configure"
+ sh "cabal sdist"
+
+ desc "run shell"
+ task "i" - do
+ sh "ghci -isrc src/Air.hs"
+
+ desc "put all .hs files in manifest"
+ task "manifest" - do
+ sh "find . | grep 'hs$' > manifest"
3 Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+
42 air.cabal
@@ -0,0 +1,42 @@
+Name: air
+Version: 2011.5.20
+Build-type: Simple
+Synopsis: air
+Description: An alternative Haskell Prelude library.
+License: BSD3
+Author: Jinjing Wang
+Maintainer: Jinjing Wang <nfjinjing@gmail.com>
+Build-Depends: base
+Cabal-version: >= 1.2
+category: Development
+license-file: LICENSE
+homepage: https://github.com/nfjinjing/air
+data-files: readme.md, changelog.md, known-issues.md
+
+library
+ ghc-options: -Wall
+
+
+ build-depends:
+ base >= 4 && < 5
+ , containers
+ , array
+ , parallel
+ , bytestring >= 0.9
+ , directory
+ , filepath
+ , template-haskell
+ , monoid-owns
+ , data-default
+ , dlist
+ , mtl
+ hs-source-dirs: src/
+ exposed-modules:
+ Air
+ , Air.Light
+ , Air.Env
+ , Air.Here.TH
+ , Air.Control.Monad.ListBuilder
+ , Air.Control.Monad.ObjectBuilder
+ , Air.Data.Record.SimpleLabel
+ , Air.Data.Record.SimpleLabel.TH
0 changelog.md
No changes.
0 known-issues.md
No changes.
2 readme.md
@@ -0,0 +1,2 @@
+An alternative Haskell Prelude library.
+
7 src/Air.hs
@@ -0,0 +1,7 @@
+module Air (
+ module Air.Env
+ , module Air.TH
+) where
+
+import Air.Env hiding (mod)
+import Air.TH
22 src/Air/Control/Monad/ListBuilder.hs
@@ -0,0 +1,22 @@
+module Air.Control.Monad.ListBuilder where
+
+
+import Control.Monad.Writer
+import Data.DList (DList, toList, singleton, fromList)
+
+type ListBuilder a b = Writer (DList a) b
+
+one :: a -> ListBuilder a ()
+one = tell . singleton
+
+many :: [a] -> ListBuilder a ()
+many = tell . fromList
+
+execListBuilder :: ListBuilder a b -> [a]
+execListBuilder = toList . execWriter
+
+list :: ListBuilder a b -> [a]
+list = execListBuilder
+
+runListBuilder :: ListBuilder a b -> (b, [a])
+runListBuilder x = let (b, a) = runWriter x in (b, toList a)
14 src/Air/Control/Monad/ObjectBuilder.hs
@@ -0,0 +1,14 @@
+module Air.Control.Monad.ObjectBuilder where
+
+
+import Control.Monad.State
+
+import Data.Default
+
+type ObjectBuilder a = State a ()
+
+execObjectBuilder :: s -> ObjectBuilder s -> s
+execObjectBuilder s m = execState m s
+
+object :: (Default s) => ObjectBuilder s -> s
+object = execObjectBuilder def
91 src/Air/Data/Record/SimpleLabel.hs
@@ -0,0 +1,91 @@
+-- a fork of Sebastiaan Visser's BSD3 fclabels
+
+{-# LANGUAGE TypeOperators, TypeSynonymInstances, TemplateHaskell #-}
+
+module Air.Data.Record.SimpleLabel
+ (
+ -- * Getter, setter and modifier types.
+ Getter
+ , Setter
+ , Modifier
+
+ -- * Label type.
+ , Point
+ , (:->) (Label)
+ , label
+ , get, set, mod
+ , getM, setM, modM
+ , (=:)
+
+ -- * Derive labels using Template Haskell.
+ , module Air.Data.Record.SimpleLabel.TH
+ )
+where
+
+import Prelude hiding ((.), id, mod)
+import Control.Applicative
+import Control.Category
+import Control.Monad.State hiding (get)
+import Air.Data.Record.SimpleLabel.TH
+
+
+type Getter s x = s -> x
+type Setter s x = x -> s -> s
+type Modifier s x = (x -> x) -> s -> s
+
+data Point s x = Point
+ { _get :: Getter s x
+ , _set :: Setter s x
+ }
+
+_mod :: Point s x -> (x -> x) -> s -> s
+_mod l f a = _set l (f (_get l a)) a
+
+newtype (s :-> x) = Label { unLabel :: Point s x }
+
+
+-- Create a label out of a getter and setter.
+
+label :: Getter s x -> Setter s x -> s :-> x
+label g s = Label (Point g s)
+
+-- | Get the getter function from a label.
+
+get :: (s :-> x) -> s -> x
+get = _get . unLabel
+
+-- | Get the setter function from a label.
+
+set :: (s :-> x) -> x -> s -> s
+set = _set . unLabel
+
+-- | Get the modifier function from a label.
+
+mod :: (s :-> x) -> (x -> x) -> s -> s
+mod = _mod . unLabel
+
+instance Category (:->) where
+ id = Label (Point id const)
+ (Label a) . (Label b) = Label (Point (_get a . _get b) (_mod b . _set a))
+
+-- | Get a value out of state pointed to by the specified label.
+
+getM :: MonadState s m => s :-> b -> m b
+getM = gets . get
+
+-- | Set a value somewhere in state pointed to by the specified label.
+
+setM :: MonadState s m => s :-> b -> b -> m ()
+setM l = modify . set l
+
+-- | Alias for `setM' that reads like an assignment.
+
+infixr 7 =:
+(=:) :: MonadState s m => s :-> b -> b -> m ()
+(=:) = setM
+
+-- | Modify a value with a function somewhere in state pointed to by the
+-- specified label.
+
+modM :: MonadState s m => s :-> b -> (b -> b) -> m ()
+modM l = modify . mod l
33 src/Air/Data/Record/SimpleLabel/TH.hs
@@ -0,0 +1,33 @@
+module Air.Data.Record.SimpleLabel.TH (mkLabels, mkLabel) where
+
+import Control.Monad
+import Data.Char
+import Language.Haskell.TH.Syntax
+
+-- | Derive labels for all the record selector in a datatype.
+mkLabels :: [Name] -> Q [Dec]
+mkLabels = liftM concat . mapM mkLabel
+
+mkLabel :: Name -> Q [Dec]
+mkLabel n = do
+ i <- reify n
+ let -- only process data and newtype declarations
+ cs' = case i of
+ TyConI (DataD _ _ _ cs _) -> cs
+ TyConI (NewtypeD _ _ _ c _) -> [c]
+ _ -> []
+ -- we're only interested in labels of record constructors
+ ls' = [ l | RecC _ ls <- cs', l <- ls ]
+ return (map mkLabel1 ls')
+
+mkLabel1 :: VarStrictType -> Dec
+mkLabel1 (name, _, _) =
+ -- Generate a name for the label:
+ -- in this fork: label names are "__" + accesser name, e.g. if data Square = Square {length :: Double}, then label is __length
+ let n = mkName $ "__" ++ nameBase name
+ in FunD n [Clause [] (NormalB (
+ AppE (AppE (VarE (mkName "label")) (VarE name)) -- getter
+ (LamE [VarP (mkName "b"), VarP (mkName "a")] -- setter
+ (RecUpdE (VarE (mkName "a")) [(name, VarE (mkName "b"))]))
+ )) []]
+
14 src/Air/Env.hs
@@ -0,0 +1,14 @@
+module Air.Env (
+ module Air.Light
+ , module Prelude
+ , module Data.Monoid.Owns
+ , module Air.Control.Monad.ListBuilder
+ , module Air.Control.Monad.ObjectBuilder
+
+) where
+
+import Air.Light
+import Prelude hiding ((.), (>), (<), (^), (/), (-), (+), drop, length)
+import Data.Monoid.Owns ((+))
+import Air.Control.Monad.ListBuilder
+import Air.Control.Monad.ObjectBuilder
11 src/Air/Here/TH.hs
@@ -0,0 +1,11 @@
+-- {-# LANGUAGE CPP #-}
+
+module Air.Here.TH where
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Lib
+
+
+here :: QuasiQuoter
+here = QuasiQuoter (litE . stringL) (litP . stringL)
377 src/Air/Light.hs
@@ -0,0 +1,377 @@
+module Air.Light where
+
+
+import Control.Arrow ((&&&), (>>>), (<<<))
+import Control.Category (Category)
+import Data.Char
+import Data.Foldable (elem, foldl, foldl', toList, Foldable)
+import Data.Function (on)
+import Debug.Trace
+import Prelude hiding ((.), (^), (>), (<), (/), (-), elem, foldl, foldl1, length, drop)
+import qualified Prelude as P
+import System.FilePath ((</>))
+import qualified Data.Array as A
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.List ( genericDrop, genericLength )
+
+import qualified Control.Monad as Monad
+
+import Control.Concurrent
+import System.Exit ( exitWith, ExitCode(ExitSuccess) )
+
+
+-- base DSL
+{-# INLINE (.) #-}
+(.) :: a -> (a -> b) -> b
+a . f = f a
+infixl 9 .
+
+(>) :: (Category cat) => cat a b -> cat b c -> cat a c
+(>) = (>>>)
+infixl 8 >
+
+(<) :: (Category cat) => cat b c -> cat a b -> cat a c
+(<) = (<<<)
+infixr 8 <
+
+(^) :: (Functor f) => f a -> (a -> b) -> f b
+(^) = flip fmap
+infixl 8 ^
+
+(/) :: FilePath -> FilePath -> FilePath
+(/) = (</>)
+infixl 5 /
+
+{-# INLINE (-) #-}
+(-) :: (a -> b) -> a -> b
+f - x = f x
+infixr 0 -
+
+(<->) :: (Num a) => a -> a -> a
+(<->) = (P.-)
+infix 6 <->
+
+
+-- List
+join :: [a] -> [[a]] -> [a]
+join = L.intercalate
+
+join' :: [[a]] -> [a]
+join' = concat
+
+first, second, third, forth, fifth :: (Show a) => [a] -> a
+sixth, seventh, eighth, ninth, tenth :: (Show a) => [a] -> a
+first = head
+second = at 1
+third = at 2
+forth = at 3
+fifth = at 4
+sixth = at 5
+seventh = at 6
+eighth = at 7
+ninth = at 8
+tenth = at 10
+
+-- Set requires Ord instance, so use nub when
+-- xs is not comparable
+unique :: (Ord a) => [a] -> [a]
+unique = to_set > to_list
+
+is_unique :: (Ord a) => [a] -> Bool
+is_unique xs = xs.unique.length == xs.length
+
+same :: (Ord a) => [a] -> Bool
+same = unique > length > is 1
+
+times :: b -> Int -> [b]
+times = flip replicate
+
+upto :: (Enum a) => a -> a -> [a]
+upto = flip enumFromTo
+
+downto :: (Num t, Enum t) => t -> t -> [t]
+downto m n = [n, n <-> 1.. m]
+
+remove_at :: Int -> [a] -> [a]
+remove_at n xs = xs.take n ++ xs.drop (n+1)
+
+insert_at, replace_at :: Int -> a -> [a] -> [a]
+insert_at n x xs = splitted.fst ++ [x] ++ splitted.snd
+ where splitted = xs.splitAt n
+replace_at n x xs = xs.take n ++ [x] ++ xs.drop (n+1)
+
+slice :: Int -> Int -> [a] -> [a]
+slice l r = take r > drop l
+
+cherry_pick :: [Int] -> [a] -> [a]
+cherry_pick ids xs = ids.map(xs !!)
+
+reduce, reduce' :: (a -> a -> a) -> [a] -> a
+reduce = L.foldl1
+reduce' = L.foldl1'
+
+inject, inject' :: (Foldable t) => a -> (a -> b -> a) -> t b -> a
+inject = flip foldl
+inject' = flip foldl'
+
+none_of :: (a -> Bool) -> [a] -> Bool
+none_of f = any f > not
+
+select, reject :: (a -> Bool) -> [a] -> [a]
+select = filter
+reject f = filter (f > not)
+
+inner_map :: (a -> b) -> [[a]] -> [[b]]
+inner_map f = map (map f)
+
+inner_reduce :: (a -> a -> a) -> [[a]] -> [a]
+inner_reduce f = map (reduce f)
+
+inner_inject :: (Foldable t) => a -> (a -> b -> a) -> [t b] -> [a]
+inner_inject x f = map (inject x f)
+
+label_by :: (a -> c) -> [a] -> [(c, a)]
+label_by f = map (f &&& id)
+
+labeling :: (a -> c') -> [a] -> [(a, c')]
+labeling f = map(id &&& f)
+
+in_group_of :: Int -> [t] -> [[t]]
+in_group_of _ [] = []
+in_group_of n xs = h : t.in_group_of(n) where (h, t) = xs.splitAt(n)
+
+split_to :: Int -> [a] -> [[a]]
+split_to n xs = xs.in_group_of(size) where
+ l = xs.length
+ size = if l P.< n then 1 else l `div` n
+
+apply, send_to :: a -> (a -> b) -> b
+apply x f = f x
+send_to = apply
+
+let_receive :: (a -> b -> c) -> b -> a -> c
+let_receive f = flip f
+
+map_send_to :: a -> [a -> b] -> [b]
+map_send_to x = map (send_to(x))
+
+belongs_to :: (Foldable t, Eq a) => t a -> a -> Bool
+belongs_to = flip elem
+
+has :: (Foldable t, Eq b) => b -> t b -> Bool
+has = flip belongs_to
+
+indexed :: (Num t, Enum t) => [b] -> [(t, b)]
+indexed = zip([0..])
+
+map_with_index :: (Num t, Enum t) => ((t, b) -> b1) -> [b] -> [b1]
+map_with_index f = indexed > map f
+
+ljust, rjust :: Int -> a -> [a] -> [a]
+rjust n x xs
+ | n P.< xs.length = xs
+ | otherwise = ( n.times x ++ xs ).reverse.take n.reverse
+
+ljust n x xs
+ | n P.< xs.length = xs
+ | otherwise = ( xs ++ n.times x ).take n
+
+
+powerslice :: [a] -> [[a]]
+powerslice xs = [ xs.slice j (j+i) |
+ i <- l.downto 1,
+ j <- [0..l <-> i]
+ ]
+ where l = xs.length
+
+-- only works for sorted list
+-- but could be infinite
+-- e.g. a `common` b `common` c
+common :: (Ord a) => [a] -> [a] -> [a]
+common _ [] = []
+common [] _ = []
+common a@(x:xs) b@(y:ys)
+ | x .is y = y : common xs b
+ | x P.< y = common xs b
+ | otherwise = common a ys
+
+
+-- faster reverse sort
+rsort :: (Ord a) => [a] -> [a]
+rsort xs = xs.L.sortBy(\a b -> b `compare` a)
+
+encode :: (Eq a) => [a] -> [(Int, a)]
+encode xs = xs.L.group.map (length &&& head)
+
+decode :: [(Int, a)] -> [a]
+decode xs = xs.map(\(l,x) -> l.times x).join'
+
+
+only_one :: [a] -> Bool
+only_one [_] = True
+only_one _ = False
+
+concat_map :: (a -> [b]) -> [a] -> [b]
+concat_map = concatMap
+
+-- Fold
+to_list :: (Foldable t) => t a -> [a]
+to_list = toList
+
+-- Set
+to_set :: (Ord a) => [a] -> S.Set a
+to_set = S.fromList
+
+-- Map
+to_h :: (Ord k) => [(k, a)] -> M.Map k a
+to_h xs = xs.M.fromList
+
+-- Array
+to_a :: [a] -> A.Array Int a
+to_a xs = A.listArray (0, xs.length <-> 1) xs
+
+to_a' :: (A.Ix i) => (i, i) -> [e] -> A.Array i e
+to_a' i xs = A.listArray i xs
+
+hist :: (Num e, A.Ix i) => (i, i) -> [i] -> A.Array i e
+hist bnds ns = A.accumArray (+) 0 bnds [(n, 1) | n <- ns, A.inRange bnds n]
+
+-- Ord
+compare_by :: (Ord b) => (a -> b) -> a -> a -> Ordering
+compare_by = on compare
+
+eq, is, is_not, isn't, aren't :: (Eq a) => a -> a -> Bool
+eq = flip (==)
+is = eq
+is_not a b = not (is a b)
+isn't = is_not
+aren't = is_not
+
+-- Tuple
+swap :: (a, b) -> (b, a)
+swap (x,y) = (y,x)
+
+tuple2 :: (Show a) => [a] -> (a, a)
+tuple2 = first &&& last
+
+tuple3 :: (Show a) => [a] -> (a, a, a)
+tuple3 xs = (xs.first, xs.second, xs.third)
+
+list2 :: (a, a) -> [a]
+list2 (x,y) = [x,y]
+
+list3 :: (a, a, a) -> [a]
+list3 (x,y,z) = [x,y,z]
+
+filter_fst :: (a -> Bool) -> [(a, b)] -> [(a, b)]
+filter_fst f = filter(fst > f)
+
+filter_snd :: (b -> Bool) -> [(a, b)] -> [(a, b)]
+filter_snd f = filter(snd > f)
+
+only_fst :: [(a, b)] -> [a]
+only_fst = map fst
+
+only_snd :: [(a, b)] -> [b]
+only_snd = map snd
+
+map_fst :: (a -> b) -> [(a, c)] -> [(b, c)]
+map_fst f = map(\(a,b) -> (f a, b))
+
+map_snd :: (a -> b) -> [(c, a)] -> [(c, b)]
+map_snd f = map(\(a,b) -> (a, f b))
+
+pair :: ((a, b) -> c) -> a -> b -> c
+pair f a b = f (a,b)
+
+triple :: ((a, b, c) -> d) -> a -> b -> c -> d
+triple f a b c = f (a,b,c)
+
+splat :: (a -> b -> c) -> (a, b) -> c
+splat f (a,b) = f a b
+
+splat3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+splat3 f (a,b,c) = f a b c
+
+twin :: a -> (a, a)
+twin x = (x,x)
+
+-- Integer
+from_i :: (Integral a, Num b) => a -> b
+from_i = fromIntegral
+
+explode :: (Show a) => a -> [Int]
+explode n = n.show.map digitToInt
+
+-- String
+lower, upper :: String -> String
+lower = map toLower
+upper = map toUpper
+
+starts_with, ends_with :: String -> String -> Bool
+starts_with = L.isPrefixOf
+ends_with = L.isSuffixOf
+
+capitalize :: String -> String
+capitalize [] = []
+capitalize (x:xs) = [x].upper ++ xs.lower
+
+to_s :: (Show a) => a -> String
+to_s = show
+
+
+-- Debug
+trace' :: (Show a) => a -> a
+trace' x = trace (x.show) x
+
+
+
+-- New from Lab
+at :: (Show a) => Int -> [a] -> a
+at i xs = if i P.< xs.length
+ then xs !! i
+ else error - show xs ++ " at " ++ show i ++ " failed"
+
+void :: (Monad m) => m a -> m ()
+void x = x >>= const () > return
+
+don't :: (Monad m) => m a -> m ()
+don't = const - return ()
+
+length :: (Num i) => [a] -> i
+length = genericLength
+
+drop :: (Integral i) => i -> [a] -> [a]
+drop = genericDrop
+
+to_f :: (Real a, Fractional b) => a -> b
+to_f = realToFrac
+
+sleep :: (RealFrac a) => a -> IO ()
+sleep x = threadDelay - round - (x * 1000000)
+
+first_or :: a -> [a] -> a
+first_or x xs = case xs of
+ [] -> x
+ (y:_) -> y
+
+puts :: String -> IO ()
+puts = putStrLn
+
+
+exit_success :: IO ()
+exit_success = exitWith ExitSuccess
+
+fork :: IO a -> IO ()
+fork io = void - forkIO - void io
+
+insert_unique :: (Eq a) => a -> [a] -> [a]
+insert_unique x xs = x : xs.reject (is x)
+
+squeeze :: (Monad m) => m (m a) -> m a
+squeeze = Monad.join
+
+end :: (Monad m) => m ()
+end = return ()
8 src/Air/TH.hs
@@ -0,0 +1,8 @@
+module Air.TH (
+ module Air.Data.Record.SimpleLabel
+ , module Air.Here.TH
+) where
+
+import Air.Data.Record.SimpleLabel
+import Air.Here.TH
+

0 comments on commit 9f6e95c

Please sign in to comment.