sparser (empty) → 0.6
raw patch · 4 files changed
+612/−0 lines, 4 filesdep +basedep +containersdep +data-defaultsetup-changed
Dependencies added: base, containers, data-default, monadplus, nats, pointed, semigroups
Files
- COPYING +26/−0
- Setup.lhs +4/−0
- sparser.cabal +35/−0
- src/Data/Sparser.hs +547/−0
+ COPYING view
@@ -0,0 +1,26 @@++Copyright (c) 2013, Hans Höglund+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 the <organization> nor the+ names of its 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 <COPYRIGHT HOLDER> 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.+
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ sparser.cabal view
@@ -0,0 +1,35 @@++name: sparser+version: 0.6+cabal-version: >= 1.10+author: Hans Hoglund+maintainer: Hans Hoglund <hans@hanshoglund.se>+license: BSD3+license-file: COPYING+synopsis: Lightweight parsing library based on partial functions.+category: +tested-with: GHC+build-type: Simple++description:+ To be written.++source-repository head+ type: git+ location: git://github.com/hanshoglund/sparser.git++library+ build-depends:+ base >= 4 && < 5,+ nats,+ semigroups,+ pointed,+ monadplus,+ data-default,+ containers + -- containers DEBUG+ + hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules:+ Data.Sparser
+ src/Data/Sparser.hs view
@@ -0,0 +1,547 @@++{-# LANGUAGE GeneralizedNewtypeDeriving,+ ScopedTypeVariables,+ BangPatterns,+ OverloadedStrings,+ TypeOperators,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleInstances+ #-}+++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (GNTD, DeriveFunctor, OverloadedStrings)+--+-- Lightweight parsing library based on partial functions.+--+-------------------------------------------------------------------------------------++module Data.Sparser (+ -- * Sparser+ SparserT,+ Sparser,+ asSparser,++ -- * Running+ runSparser,+ runSparserT,+ runSparserT',+ withState,++ -- * Primitives+ stateP,+ -- mapStateP,+ -- mapInputP,+ headP,+ splitP,+ gateP,+ atEnd,++ -- * Basic parsers+ char, + notChar,+ charIf,+ string,+ stringIf,+ space,+ integer,+ stringLiteral,+ brackets,+ braces,+ complete,+ ifState,++ -- * Combinators+ between,+ skipMany1,+ skipMany,+ many1,+ sepBy,+ sepBy1,+ sepEndBy1,+ sepEndBy,+ endBy1,+ endBy,+ count+) where++import Data.Char+import Data.Maybe -- DEBUG+import Data.Ratio -- DEBUG+import Data.String+import Data.Tree+import Data.Default+import Data.Pointed+import Data.Semigroup+import Data.Foldable(Foldable)+import Control.Applicative+import Control.Monad.Plus+++newtype a ?-> b = PartialP { getPartialP :: a -> Maybe (a, b) }++instance Functor ((?->) r) where+ fmap f (PartialP g) = PartialP (fmap (fmap f) . g)++instance Monad ((?->) r) where+ return x = PartialP (\a -> Just (a, x))+ PartialP f >>= k = PartialP $ \r -> (f r >>= \(r1, x) -> getPartialP (k x) r1)++instance MonadPlus ((?->) r) where+ mzero = PartialP (const Nothing)+ PartialP f `mplus` PartialP g = PartialP $ \x -> f x `mplus` g x++instance Applicative ((?->) r) where+ pure = return+ (<*>) = ap++instance Alternative ((?->) r) where+ empty = mzero+ (<|>) = mplus++instance Pointed ((?->) r) where+ point = return++instance Semigroup ((?->) a b) where+ (<>) = mplus++instance Monoid ((?->) a b) where+ mempty = mzero+ mappend = mplus+++----------++newtype SparserT s a b = SparserT { getSparserT :: (s, [a]) ?-> b }+ deriving (Semigroup, Monoid, Functor, Pointed, Applicative, Alternative, Monad, MonadPlus)++asSparser = id+asSparser :: Sparser a -> Sparser a++instance IsString (SparserT s Char String) where+ fromString = string++type Sparser = SparserT () Char++-- | +-- Run a parser, returning the result.+-- +runSparser :: Sparser a -> String -> Maybe a+runSparser p = runSparserT p ()++-- | +-- Run a parser with a custom state, returning the result.+-- +runSparserT :: SparserT s a b -> s -> [a] -> Maybe b+runSparserT = curry . fmap (fmap snd) . getPartialP . getSparserT++-- | +-- Run a parser with a custom state.+--+-- This is the most general way to run a parser. It returns the final state,+-- remaining input and the result.+-- +runSparserT' :: SparserT s a b -> s -> [a] -> Maybe (s, [a], b)+runSparserT' = curry . fmap (fmap untrip) . getPartialP . getSparserT+ where untrip ((a,b),c) = (a,b,c)++withState :: (s -> t) -> (t -> s) -> SparserT t a b -> SparserT s a b+withState setup teardown (SparserT (PartialP f)) = (SparserT (PartialP $ ws f))+ where+ ws f = fmap (first (first teardown)) . f . first setup+++----------++-- | Return the state as result.+stateP :: SparserT s a s+stateP = (SparserT (PartialP st))+ where+ st = \(s, as) -> Just ((s, as), s)++{-+-- | Transform state.+mapStateP :: (s -> s) -> SparserT s a ()+mapStateP f = (SparserT (PartialP st))+ where+ st = \(s, as) -> Just ((f s, as), ())++-- | Transform input.+mapInputP :: ([a] -> [a]) -> SparserT s a ()+mapInputP f = (SparserT (PartialP st))+ where+ st = \(s, as) -> Just ((s, f as), ())+-}+++-- | Consumes one input element.+--+-- Fails if the predicate fails, or if there is no more input.+--+headP :: (s -> a -> Bool) -> SparserT s a a+headP = SparserT . PartialP . headP'+++-- | Consume one or more input elements.+--+-- The given function receives the /entire/ remaining input, and must return+-- the number of consumed elements.+--+-- Fails if the predicate return 0 or less, or if there is no more input.+--+splitP :: (s -> [a] -> Int) -> SparserT s a [a]+splitP = SparserT . PartialP . splitP'++-- | Succeed based on predicate, but do not consume input.+--+-- The given function receives the /entire/ remaining input.+--+gateP :: (s -> [a] -> Bool) -> SparserT s a ()+gateP = SparserT . PartialP . gateP'++atEnd :: SparserT s a ()+atEnd = SparserT $ PartialP atEnd'+++headP' :: (s -> a -> Bool) -> (s, [a]) -> Maybe ((s, [a]), a)+headP' p (s, []) = Nothing+headP' p (s, (x:xs)) = if not (p s x) then Nothing else Just ((s, xs), x)++splitP' :: (s -> [a] -> Int) -> (s, [a]) -> Maybe ((s, [a]), [a])+splitP' p (s, []) = Nothing+splitP' p (s, ys) = let n = p s ys in if n < 1 then Nothing else Just ((s, drop n ys), take n ys)++gateP' :: (s -> [a] -> Bool) -> (s, [a]) -> Maybe ((s, [a]), ())+gateP' p (s, []) = Nothing+gateP' p (s, xs) = if not (p s xs) then Nothing else Just ((s, xs), ())+++atEnd' :: (s, [a]) -> Maybe ((s, [a]), ())+atEnd' (s, []) = Just ((s, []), ())+atEnd' (s, xs) = Nothing++----------++complete :: SparserT s a b -> SparserT s a b+complete x = do+ res <- x+ atEnd+ return res+++ifState :: (s -> Bool) -> SparserT s a b -> SparserT s a b+ifState p x = gateP (\s _ -> p s) >> x++-- char :: Char -> Sparser Char++char c = charIf (== c)++notChar c = charIf (/= c)++-- charIf :: (Char -> Bool) -> Sparser Char+charIf p = headP (const p)++-- string :: String -> Sparser String+string s = stringIf (length s) (== s)++-- stringIf :: Int -> (String -> Bool) -> Sparser String+stringIf n p = splitP (\_ xs -> if p (take n xs) then n else 0)++----------++-- Use applicative optional+between open close p+ = do{ open; x <- p; close; return x }+skipMany1 p = do{ p; skipMany p }+skipMany p = scan+ where+ scan = do{ p; scan } <|> return ()+many1 p = do{ x <- p; xs <- many p; return (x:xs) }+sepBy p sep = sepBy1 p sep <|> return []+sepBy1 p sep = do{ x <- p+ ; xs <- many (sep >> p)+ ; return (x:xs)+ }+sepEndBy1 p sep = do{ x <- p+ ; do{ sep+ ; xs <- sepEndBy p sep+ ; return (x:xs)+ }+ <|> return [x]+ }+sepEndBy p sep = sepEndBy1 p sep <|> return []+endBy1 p sep = many1 (do{ x <- p; sep; return x })+endBy p sep = many (do{ x <- p; sep; return x })+count n p | n <= 0 = return []+ | otherwise = sequence (replicate n p)++----------++space = many1 (charIf isSpace)+symbol = many1 (charIf isAlphaNum)++integer :: SparserT s Char Integer+integer = read <$> many1 (charIf isDigit)++stringLiteral :: SparserT s Char String+stringLiteral = between (char '"') (char '"') $ many (notChar '"')++brackets = between (char '{') (char '}')+braces = between (char '[') (char ']')++----------++-- Tests+++++test :: SparserT Int Char String+test = withState id id $ do+ ifState (== 0) $ string "name:"+ optional space + n <- symbol+ m <- withState (+ 10) (subtract 10) stateP+ optional space+ many1 (string ";")+ optional space+ return ("Name is " ++ n ++ ", state is " ++ show m)+++data JSON+ = Object [(String, JSON)]+ | Array [JSON]+ | String String+ | Number Double+ | Boolean Bool+ | Null+ deriving (Eq, Ord, Show)++json :: SparserT s Char JSON+json = empty+ <|> (Object <$> members)+ <|> (Array <$> elements)+ <|> (String <$> stringLiteral)+ <|> ((Number . fromIntegral) <$> integer)+ <|> (const (Boolean False) <$> string "false")+ <|> (const (Boolean True) <$> string "true")+ <|> (const Null <$> string "null") + where + members = brackets (pair `sepBy` (char ',' >> optional space))+ elements = braces (value `sepBy` (char ',' >> optional space))++ pair = do+ n <- stringLiteral+ optional space+ string ":"+ optional space+ v <- json+ return (n, v)+ + value = json++----------++type Duration = Double++data Rhythm a+ = Beat !Duration a -- d is divisible by 2+ | Group ![Rhythm a] -- normal note sequence+ | Dots !Int !(Rhythm a) -- n > 0.+ | Tuplet !Duration !(Rhythm a) -- d is an emelent of 'tupletMods'.+ deriving (Eq, Show, Functor, Foldable)++rhTree :: Show a => Rhythm a -> Tree String+rhTree = go+ where+ go (Beat d a) = Node (showDur d{- ++ ":" ++ show a-}) []+ go (Group as) = Node "" (fmap rhTree as)+ go (Dots n a) = Node ("dot:" ++ show n) [rhTree a]+ go (Tuplet d a) = Node ("tuplet:" ++ showDur d) [rhTree a]+ -- (realToFrac d :: Double) + + showDur x = show (numerator (toRational x)) ++ "/"+ ++ show (denominator (toRational x))++putRh :: Show a => Maybe (Rhythm a) -> IO () +putRh = putStrLn . drawTree . rhTree . fromMaybe (error "Could not quantize")++instance Semigroup (Rhythm a) where+ (<>) = mappend+instance Monoid (Rhythm a) where+ mempty = Group []+ Group as `mappend` Group bs = Group (as <> bs)+ r `mappend` Group bs = Group ([r] <> bs)+ Group as `mappend` r = Group (as <> [r])++type Quant s a = SparserT s (Duration, a) (Rhythm a)++data QuantState = QuantState {+ timeMod_ :: Duration, + recur_ :: Int+ } + deriving (Eq, Show)+instance Default QuantState where def = QuantState {+ timeMod_ = 1,+ recur_ = 0+ }++class HasTimeScale a where + getTimeScale :: a -> Duration+ mapTimeScale :: (Duration -> Duration) -> a -> a+instance HasTimeScale () where+ mapTimeScale f = id + getTimeScale () = 1 +instance HasTimeScale QuantState where+ getTimeScale = timeMod_+ mapTimeScale f (QuantState tm r) = QuantState (f tm) r++class HasRecur a where+ getRecur :: a -> Int+ mapRecur :: (Int -> Int) -> a -> a+ recur, unrecur :: a -> a+ recur = mapRecur succ+ unrecur = mapRecur pred+ guardRecur :: SparserT a m n -> SparserT a m n+ guardRecur = ifState (\x -> getRecur x < kMaxRecur)+instance HasRecur QuantState where+ getRecur = recur_+ mapRecur f (QuantState tm r) = QuantState tm (f r)++testQuant :: Quant QuantState () -> [Duration] -> Maybe (Rhythm ())+testQuant p = quant p . (`zip` repeat ())++quant :: Default s => Quant s a -> [(Duration, a)] -> Maybe (Rhythm a)+quant p = quant' p def++quant' :: Quant s a -> s -> [(Duration, a)] -> Maybe (Rhythm a)+quant' = runSparserT+++++allDivs :: (HasTimeScale s, HasRecur s) => Quant s a -> Quant s a+allDivs x = msum $ fmap (`scaleTime` x) divs+ where+ divs = [8,4,2,1] ++ fmap (recip.(2^)) [1..5] :: [Duration]+++-- Tries to match 2.5, then shorter+rh5 :: (HasTimeScale s, HasRecur s) => Quant s a+rh5 = group [rh4,rh3] <|> group [rh3,rh4]++-- Tries to match 1, then shorter+rh4 :: (HasTimeScale s, HasRecur s) => Quant s a+rh4 = withState recur unrecur $ guardRecur $ empty+ -- 1+ <|> note++ -- 1/4 1/4 1/4 1/4+ <|> (quarter (group [rh4, rh4, rh4, rh4]))++ -- 1/2 1/2+ <|> (half (group [rh4, rh4]))++ -- 1/4 1/2 1/4+ <|> (half (group [half rh4, rh4, half rh4]))++ -- dotted figures+ <|> (half (group [rh3, half rh4]))+ <|> (half (group [half rh4, rh3]))++++-- Tries to match 1+1/2, then shorter+rh3 :: (HasTimeScale s, HasRecur s) => Quant s a+rh3 = withState recur unrecur $ empty+ -- 1+1/2+ <|> dot note++ -- 1/2 1/2 1/2+ <|> (triple (half (group [rh4, rh4, rh4])))++ -- 1 1/2+ <|> (group [unit rh4, half rh4])++ -- 1/2 1+ <|> (group [half rh4, unit rh4])+++-- Tries to match something in scale 1.5+dot, unit, double, half, triple, quarter :: (HasTimeScale s, HasRecur s) => Quant s a -> Quant s a+dot = fmap (Dots 1) . scaleTime (3/2)+unit = scaleTime (2/2)+double = scaleTime (2/1)+half = scaleTime (1/2)+quarter = scaleTime (1/4)+triple = scaleTime (1/3)++-- Tries to match 1 as a note+note :: (HasTimeScale s, HasRecur s) => Quant s a+note = noteIf (\s d x -> d / getTimeScale s == 1)++scaleTime :: (HasTimeScale s, HasRecur s) => Duration -> Quant s a -> Quant s a+scaleTime n = withState + (mapTimeScale (* n)) + (mapTimeScale (/ n))++group :: [Quant s a] -> Quant s a+group xs = Group <$> sequence xs++kMaxRecur = 6+-- 5+r = [2,2,1,1,1,1, 2,2,1,3, 0.5,0.5,1,1,1] :: [Duration]++-- 5+r2 = [2,2, 1,1,1,2,1,2, 1,3, 0.5,0.5,1,1,1] :: [Duration]++-- 4+r3 = [1,1,2,3,1]:: [Duration]+++-- Mathes a single note whose duration is simple+-- note :: Quant s a+-- note = noteIf (\s d x -> isDivisibleBy 2 d)++++noteIf :: (s -> Duration -> a -> Bool) -> Quant s a+noteIf p = uncurry beat <$> headP (\s (d,x) -> p s d x)+ where+ beat :: Duration -> a -> Rhythm a+ beat d x = Beat d x+ ++++++-- As it sounds+isDivisibleBy :: Duration -> Duration -> Bool+isDivisibleBy n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational++logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a+logBaseR k n+ | isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1+logBaseR k n+ | isDenormalized (fromRational n :: a) = logBaseR k (n*k) - 1+logBaseR k n = logBase (fromRational k) (fromRational n)+++----------++first f (a, b) = (f a, b)+single x = [x]+list z f xs = case xs of+ [] -> z+ ys -> f ys++-- [a,b,c,d,e,f,g,x,y,z,m,n,o,p,q,r] = undefined