Parser

bird/src/Exercise/Think_01_F.hs

@@ -3,13 +3,14 @@ module Exercise.Think_01_F where
 
 import Prelude hiding (
     Word
+  , take
+  , concat
   )
 
-import Data.List (
-    sort
+import Data.Char (
+    toLower
   )
 
-
 -- anagrams :: Int -> [Word] -> String
 
 -- |
@@ -22,8 +23,23 @@ import Data.List (
 
 -- / 1.3
 -- |
+-- >>> putStr . commonWords 3 $ "to be or not to be"
+--   be  2
+--   to  2
+--   not  1
+--
+
+commonWords :: Int -> ([Char] -> [Char])
+-- |
+-- >>> commonWords 3 "to be or not to be"
+-- "  be  2\n  to  2\n  not  1\n"
+--
+commonWords n =
+    concat. map showRun . take n
+  . sortRuns . countRuns
+  . sortWords . words . map toLower
+-- |
 
--- commonWords :: Int -> ([Char] -> [Char])
 
 type Text = [Char]
 type Word = [Char]
@@ -44,22 +60,71 @@ sortWords :: [Word] -> [Word]
 sortWords = sort
 -- |
 
+sort :: Ord a => [a] -> [a]
+sort []     = []
+sort (x:xs) =
+  sort lessOrEqual ++ [x] ++ sort greater
+  where
+    lessOrEqual = [a | a <- xs, a < x || a == x]
+    greater     = [a | a <- xs, a > x]
+
+
 countRuns :: [Word] -> [(Int,Word)]
 -- |
 -- >>> countRuns ["be","be","not","or","to","to"]
 -- [(2,"be"),(1,"not"),(1,"or"),(2,"to")]
 --
-countRuns xs = map f . nubBy (==) $ xs
+countRuns wrdLs = map f . nubBy (==) $ wrdLs
   where
-    f = \x ->
-      (g x, x)
-    g = \x ->
-      length . filter ((==) x) $ xs
+    f = \x -> (g x, x)
+    g = \x -> length . filter ((==) x) $ wrdLs
+-- |
 
 nubBy :: (a -> a -> Bool) -> [a] -> [a]
 nubBy eq []     =  []
 nubBy eq (x:xs) =
   (:) x . nubBy eq . filter (not . eq x) $ xs
+
+
+sortRuns :: [(Int,Word)] -> [(Int,Word)]
+-- |
+-- >>> sortRuns [(2,"be"),(1,"not"),(1,"or"),(2,"to")]
+-- [(2,"be"),(2,"to"),(1,"not"),(1,"or")]
+--
+sortRuns []     = []
+sortRuns (x:xs) =
+  sortRuns greater ++ [x] ++ sortRuns lessOrEqual
+  where
+    greater     = [(int,wrd) | (int,wrd) <- xs, int > fst x]
+    lessOrEqual = [(int,wrd) | (int,wrd) <- xs, int < fst x || int == fst x]
+
+
+take :: Int -> [a] -> [a]
+take n xs | 0 < n     = unsafeTake n xs
+          | otherwise = []
+
+unsafeTake :: Int -> [a] -> [a]
+unsafeTake _ []     = []
+unsafeTake 1 (x: _) = [x]
+unsafeTake n (x:xs) = x : unsafeTake (n - 1) xs
+
+
+showRun :: (Int,Word) -> String
+-- |
+-- >>> showRun (2,"be")
+-- "  be  2\n"
+--
+showRun (int,wrd) =
+  "  " ++ wrd ++ "  " ++ show int ++ "\n"
+-- |
+
+
+concat :: [[a]] -> [a]
+-- |
+-- >>> concat [[0],[1]]
+-- [0,1]
+--
+concat = foldr (++) []
 -- |
 
 

hutton/src/Parser.hs

@@ -3,51 +3,195 @@ module Parser (
   ) where
 
 import Data.Char
+import Control.Applicative
+  hiding (many, some)
 
 import Prelude hiding (
     return
   )
 
 -- // Type
 
-type Parser a =
-  String -> [(a,String)]
+newtype Parser a =
+  P (String -> [(a,String)])
+
+parse :: Parser a -> String -> [(a,String)]
+-- |
+parse (P p) inp = p inp
+-- |
+
 
 -- // Base
 
 return :: a -> Parser a
 -- |
-return v = \ inp ->
-  [(v,inp)]
+-- >>> parse (return 1) "abc"
+-- [(1,"abc")]
+--
+return v = P $ \inp -> [(v,inp)]
 -- |
 
 failure :: Parser a
 -- |
-failure = \ inp ->
-  []
+-- >>> parse failure "abc"
+-- []
+--
+failure = P $ \inp -> []
 
 item :: Parser Char
 -- |
-item = \ inp -> case inp of
-  [] ->
-    []
-  (x:xs) ->
-    [(x, xs)]
--- |
-
-parse :: Parser a -> String -> [(a,String)]
--- |
--- >>> parse (return 1) "abc"
--- [(1,"abc")]
--- >>> parse failure "abc"
--- []
 -- >>> parse item ""
 -- []
 -- >>> parse item "abc"
 -- [('a',"bc")]
 --
-parse p inp = p inp
+item = P $ \inp -> case inp of
+  []     -> []
+  (x:xs) -> [(x, xs)]
+-- |
+
+bool :: (a -> Bool) -> Parser a -> Parser a
+bool f p = P $ \inp -> case parse (f <$> p) inp of
+  [(True,_)] -> parse p inp
+  _          -> empty
+
+
+-- // instance
+
+instance Functor Parser where
+--  fmap :: (a -> b) -> Parser a -> Parser b
+    fmap g p = P $ \inp -> case parse p inp of
+      []        -> []
+      [(v,out)] -> [(g v,out)]
+-- |
+-- >>> flip parse "" . fmap (+1) . return $ 0
+-- [(1,"")]
+--
+
+instance Applicative Parser where
+--  pure :: a -> Parser a
+    pure v = P $ \inp -> [(v,inp)]
+--  (<*>) :: Parser (a -> b) -> Parser a -> Parser b
+    pg <*> px = P $ \inp -> case parse pg inp of
+      []        -> []
+      [(g,out)] -> parse (fmap g px) out
+-- |
+-- >>> flip parse "" . pure $ 1
+-- [(1,"")]
+-- >>> flip parse "" $ pure (+1) <*> pure 1
+-- [(2,"")]
+--
+
+instance Monad Parser where
+--  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
+    p >>= f = P $ \inp -> case parse p inp of
+      []        -> []
+      [(v,out)] -> parse (f v) out
+-- |
+-- >>> flip parse "" $ pure 0 >>= (\_ -> pure 1)
+-- [(1,"")]
+--
+
+instance Alternative Parser where
+--  empty :: Parser a
+    empty = P $ \inp -> []
+--  (<|>) :: Parser a -> Parser a -> Parser a
+    p <|> q = P $ \inp -> case parse p inp of
+      []        -> parse q inp
+      [(v,out)] -> [(v,out)]
+-- |
+-- >>> flip parse "" $ empty
+-- []
+-- >>> flip parse "" $ pure 1 <|> empty
+-- [(1,"")]
+--
+
+
+-- // Char
+
+sat :: (Char -> Bool) -> Parser Char
+sat p = P . parse $ bool p item
+
+char :: Char -> Parser Char
+-- |
+-- >>> flip parse "abc" $ char 'a'
+-- [('a',"bc")]
+char x = sat (== x)
+
+digit :: Parser Char
+digit = sat isDigit
+
+lower :: Parser Char
+lower = sat isLower
+
+upper :: Parser Char
+upper = sat isUpper
+
+letter :: Parser Char
+letter = sat isAlpha
+
+alphanum :: Parser Char
+alphanum = sat isAlphaNum
+
+
+-- // String
+
+string :: String -> Parser String
+-- |
+-- >>> flip parse "aabbcc" $ string "aa"
+-- [("aa","bbcc")]
+-- >>> flip parse "aabbcc" $ string "bb"
+-- []
+-- >>> flip parse "aabbcc" $ string "aaa"
+-- []
+string ""     = pure ""
+string (x:xs) = P . parse $ (:) <$> char x <*> string xs
+
+
+-- // Applicative
+
+many :: Parser a -> Parser [a]
+-- |
+-- >>> flip parse "123abc" $ many digit
+-- [("123","abc")]
+-- >>> flip parse "abc" $ many digit
+-- [("","abc")]
+-- >>> flip parse "abc" $ many1 digit
+-- []
+-- >>> flip parse "abc" $ some digit
+-- []
+many p = many1 p <|> pure []
+many1 :: Parser a -> Parser [a]
+many1 p = P . parse $ (:) <$> p <*> many p
+some :: Parser a -> Parser [a]
+some = many1
 -- |
 
+ident :: Parser String
+-- |
+-- >>> flip parse "a01!" $ ident
+-- [("a01","!")]
+ident = P . parse $ (:) <$> lower <*> many alphanum
+
+nat :: Parser Int
+-- |
+-- >>> flip parse "001a" $ nat
+-- [(1,"a")]
+nat = P . parse $ read <$> some digit
+
+
+-- // space
+
+space :: Parser ()
+-- |
+-- >>> flip parse "   aaa" $ space
+-- [((),"aaa")]
+space = P . parse $ pure () <$> many (sat isSpace)
+
+token :: Parser a -> Parser a
+-- |
+-- >>> flip parse " ( aaa ) " $ token (char '(')
+-- [('(',"aaa ) ")]
+token p = P . parse $ space *> p <* space