import System.Environment
import Text.ParserCombinators.Parsec hiding (spaces)
import Control.Monad

data LispVal = Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | Number Integer
             | String String
             | Bool Bool

instance Show LispVal where show = showVal

symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany1 space

parseString :: Parser LispVal
parseString = do char '"'
                 x <- many (noneOf "\"")
                 char '"'
                 return $ String x

parseAtom :: Parser LispVal
parseAtom = do first <- letter <|> symbol
               rest <- many (letter <|> digit <|> symbol)
               let atom = first:rest
               return $ case atom of 
                          "#t" -> Bool True
                          "#f" -> Bool False
                          _    -> Atom atom

parseNumber :: Parser LispVal
parseNumber = liftM (Number . read) $ many1 digit

parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces

parseDottedList :: Parser LispVal
parseDottedList = do
  head <- endBy parseExpr spaces
  tail <- char '.' >> spaces >> parseExpr
  return $ DottedList head tail

parseQuoted :: Parser LispVal
parseQuoted = do
  char '\''
  x <- parseExpr
  return $ List [Atom "quote", x]

parseExpr :: Parser LispVal
parseExpr = parseAtom
        <|> parseString
        <|> parseNumber
        <|> parseQuoted
        <|> do char '('
               x <- try parseList <|> parseDottedList
               char ')'
               return x

showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"

unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal

readExpr :: String -> String
readExpr input = case parse parseExpr "lisp" input of
    Left err -> "No match: " ++ show err
    Right val -> "Found " ++ show val

main :: IO ()
main = do args <- getArgs
          putStrLn (readExpr (args !! 0))

{-# LANGUAGE FlexibleInstances,TypeSynonymInstances #-}

import JSONClass
import Numeric
import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))

p_text :: CharParser () JValue
p_text = spaces *> text <?> "JSON text"
    where text = JObject <$> p_object
             <|> JArray <$> p_array

p_series :: Char -> CharParser () a -> Char -> CharParser () [a]
p_series left parser right =
    between (char left <* spaces) (char right) $
            (parser <* spaces) `sepBy` (char ',' <* spaces)

p_array :: CharParser () (JAry JValue)
p_array = JAry <$> p_series '[' p_value ']'

p_object :: CharParser () (JObj JValue)
p_object = JObj <$> p_series '{' p_field '}'
    where p_field = (,) <$> (p_string <* char ':' <* spaces) <*> p_value

p_value :: CharParser () JValue
p_value = value <* spaces
    where value = JString <$> p_string
              <|> JNumber <$> p_number
              <|> JObject <$> p_object
              <|> JArray <$> p_array
              <|> JBool <$> p_bool
              <|> JNull <$ string "null"
              <?> "JSON value"

p_bool :: CharParser () Bool
p_bool = True <$ string "true" <|> False <$ string "false"

p_value_choice = value <* spaces
    where value = choice [ JString <$> p_string
                         , JNumber <$> p_number
                         , JObject <$> p_object
                         , JArray <$> p_array
                         , JBool <$> p_bool
                         , JNull <$  string "null"
                         ]
                  <?> "JSON value"

p_number :: CharParser () Double
p_number = do s <- getInput
              case readSigned readFloat s of
                [(n, s')] -> n <$ setInput s'
                _ -> empty

p_string :: CharParser () String
p_string = between (char '\"') (char '\"') (many jchar)
    where jchar = char '\\' *> (p_escape <|> p_unicode)
              <|> satisfy (`notElem` "\"\\")

p_escape = choice (zipWith decode "bnfrt\\\"/" "\b\n\f\r\t\\\"/")
    where decode c r = r <$ char c

p_unicode :: CharParser () Char
p_unicode = char 'u' *> (decode <$> count 4 hexDigit)
    where decode x = toEnum code
              where ((code,_):_) = readHex x

*Main> parse p_text "(unknown)" "[1,2,3]"
Right (JArray (JAry {fromJAry = [JNumber 1.0,JNumber 2.0,JNumber 3.0]}))
*Main> parse p_text "(unknown)" "{\"test\":3}"
Right (JObject (JObj {fromJObj = [("test",JNumber 3.0)]}))

instance (JSON a) => JSON [a] where
    toJValue = undefined
    fromJValue = undefined

instance (JSON a) => JSON [(String, a)] where
    toJValue = undefined
    fromJValue = undefined

instance (JSON a) => JSON (JObj a) where
    toJValue = JObject . JObj . map (second toJValue) . fromJObj
    fromJValue (JObject (JObj o)) = whenRight JObj (mapEithers unwrap o)
        where unwrap (k,v) = whenRight ((,) k) (fromJValue v)
    fromJValue _ = Left "not a JSON object"

instance (JSON a) => JSON (JAry a) where
    toJValue = jaryToJValue
    fromJValue = jaryFromJValue

newtype JAry a = JAry {
      fromJAry :: [a]
    } deriving (Eq, Ord, Show)

newtype JObj a = JObj {
      fromJObj :: [(String, a)]
    } deriving (Eq, Ord, Show)

*JSONClass> toJValue . JObj $ [("test", 1)]
JObject (JObj {fromJObj = [("test",JNumber 1.0)]})
*JSONClass> toJValue . JAry $ [1,2,3]
JArray (JAry {fromJAry = [JNumber 1.0,JNumber 2.0,JNumber 3.0]})

Prelude> :t (,)
(,) :: a -> b -> (a, b)
Prelude> (,) 'a' 'b'
('a','b')

Prelude> 'a' , 'b'

<interactive>:33:5: parse error on input `,'

Prelude> :i (,)
data (,) a b = (,) a b  -- Defined in `GHC.Tuple'
instance (Bounded a, Bounded b) => Bounded (a, b)
  -- Defined in `GHC.Enum'
instance (Eq a, Eq b) => Eq (a, b) -- Defined in `GHC.Classes'
instance (Ord a, Ord b) => Ord (a, b) -- Defined in `GHC.Classes'
instance (Read a, Read b) => Read (a, b) -- Defined in `GHC.Read'
instance (Show a, Show b) => Show (a, b) -- Defined in `GHC.Show'

fact 0 = return 1
fact n = do
  print n
  n1 <- fact (n-1)
  return (n * n1)

import Control.Monad.Writer

factT :: Int -> WriterT [Int] IO Int
factT 0 = tell [0] >> return 1
factT n = do
  tell [n]
  n1 <- factT (pred n)

*Main> runWriterT $ factT 5
(120,[5,4,3,2,1,0])
*Main> execWriterT $ factT 5
[5,4,3,2,1,0]
*Main> liftM fst $ runWriterT $ factT 5
120

instance (Monoid w, Monad m) => Monad (WriterT w m) where
    return a = WriterT $ return (a, mempty)
    m >>= k  = WriterT $ do
        (a, w)  <- runWriterT m
        (b, w') <- runWriterT (k a)
        return (b, w `mappend` w')
    fail msg = WriterT $ fail msg

import Control.Monad.Writer

factW :: Int -> Writer [Int] Int
factW 0 = tell [0] >> return 1
factW n = do
  tell [n]
  n1 <- factW (pred n)
  return $ n * n1

*Main> runWriter $ factW 5
(120,[5,4,3,2,1,0])

pure x = (\_ -> x)
f <*> g =\x -> f x (g x)

(+) <$> (+3) <*> (*100)

Prelude Control.Applicative> :t ((+3) <*> (*100))

<interactive>:1:12:
    Occurs check: cannot construct the infinite type: a0 = a0 -> b0
    Expected type: (a0 -> b0) -> a0
      Actual type: (a0 -> b0) -> a0 -> b0
    In the second argument of `(<*>)', namely `(* 100)'
    In the expression: ((+ 3) <*> (* 100))

Prelude Control.Applicative> :t ((+) <$> (+3)) 
((+) <$> (+3)) :: Num a => a -> a -> a

Prelude Control.Applicative> (\x y z -> [x,y,z]) <$> (+3) <*> (*2) <*> (/2) $ 5
[8.0,10.0,2.5]

module CountEntries (listDirectory, countEntriesTrad) where

import System.Directory (doesDirectoryExist, getDirectoryContents)
import System.FilePath ((</>))
import Control.Monad (forM, liftM, when)

listDirectory :: FilePath -> IO [String]
listDirectory = liftM (filter notDots) . getDirectoryContents
    where notDots p = p /= "." && p /= ".."

countEntriesTrad ::FilePath -> IO [(FilePath, Int)]
countEntriesTrad path = do
  contents <- listDirectory path
  rest <- forM contents $ \name -> do
                          let newName = path </> name
                          isDir <- doesDirectoryExist newName
                          -- when isDir $ countEntriesTrad newName
                          if isDir
                             then countEntriesTrad newName
                             else return []
  return $ (path, length contents) : concat rest

module CountEntriesT (listDirectory, countEntries) where

import CountEntries (listDirectory)
import System.Directory (doesDirectoryExist)
import System.FilePath ((</>))
import Control.Monad (forM_, when)
import Control.Monad.Trans (liftIO)
import Control.Monad.Writer (WriterT, tell)

countEntries ::FilePath -> WriterT [(FilePath, Int)] IO ()
countEntries path = do
  contents <- liftIO . listDirectory $ path
  tell [(path, length contents)]
  forM_ contents $ \name -> do
                          let newName = path </> name
                          isDir <- liftIO . doesDirectoryExist $ newName
                          when isDir $ countEntries newName

when              :: (Monad m) => Bool -> m () -> m ()
when p s          =  if p then s else return ()

-- | The reverse of 'when'.

unless            :: (Monad m) => Bool -> m () -> m ()
unless p s        =  if p then return () else s

Prelude Control.Applicative> [(x*) | x <- [1..9]] <*> [1..9]

Prelude Control.Applicative> (*) <$> [1..9] <*> [1..9]

Prelude Control.Applicative> :t ((*) <$>)
((*) <$>) :: (Functor f, Num a) => f a -> f (a -> a)

Prelude Control.Applicative> :t [1..9] <*> [1..9]
[1..9] <*> [1..9]
  :: (Enum a, Enum (a -> b), Num a, Num (a -> b)) => [b]

Prelude Control.Applicative> liftA2 (*) [1..9] [1..9]

Prelude Control.Applicative> :t liftA2 (*)
liftA2 (*) :: (Num c, Applicative f) => f c -> f c -> f c