DZone Snippets: haskell code

Convert radix in haskell:

mokehehe (mokehehe) — Thu, 21 Aug 2008 12:11:39 GMT

Contert integer to array of integer what each element is target radix.



convRadix :: (Integral b) => b -> b -> [b]

convRadix n = unfoldr (\b -> if b == 0 then Nothing else Just (b `mod` n, b `div` n))

ex.
> convRadix 10 1234
[4, 3, 2, 1]
> convRadix 10 0
[]
> convRadix 10 (-1)
[9,9,...] (infinite)

Top Down Operator Precedence - in Haskell

Rohan (Rohan Hart) — Fri, 18 Jul 2008 03:42:39 GMT

A direct translation from Douglas Crockford's JavaScript parser into Haskell keeping as close as possible to the same structure and naming. Plus tokeniser and pretty-printer.

There's also a side-by-side comparison with the original JavaScript.



module TopDownParserState where



-- to stop a collision with record field id (records are kind of odd in Haskell)

import Prelude hiding (id, error, lookup)

import qualified Prelude



-- unlike Javascript there's no inbuilt data map support

import Data.Map (Map, (!), lookup, insert, member)

import qualified Data.Map as Map



-- support stateful function style

import Control.Monad.State



import Tokeniser



type Parser a = State Env a



-- Something which isn't obvious from the original variable names is

-- that 'tokens' is input yet 'token' belongs to the completely

-- different output type.

data Env = Env { scope        :: Scope,

                 symbol_table :: SymbolTable,

                 token        :: Symbol,

                 tokens       :: [Token] }



itself = return



-- This could be a simple list of scopes but I'll try to keep closely to

-- the structure of the Javascript code

data Scope = Scope { def    :: SymbolTable,

                     parent :: Scope }

           | TopScope



type SymbolTable = Map Value Symbol



define n@Symbol {value = value} = do

  this <- gets scope

  let t = def this ! value

  when (member value $ def this) $

    error n $ if reserved t

              then "Already reserved."

              else "Already defined."

  let n' = n { reserved = False,

               nudf     = itself,

               -- why redefine led here?

               ledf     = \this _ -> error this "Undefined operator.",

               std      = Nothing,

               lbp      = 0,

               skope    = this }

  env <- get

  put env { scope = this {

    def = insert value n' $ def this

  } }

  return n'



find env@Env {scope = Scope {def = def, parent = e}} n =

  case lookup n def of

    Just t -> t

    _      -> find env { scope = e} n



find Env { symbol_table = st } n =

  case lookup n st of

    Just t -> t

    _      -> st ! "(name)"



pop = do

  env <- get

  put env { scope = parent $ scope env }



reserve n@Symbol {arity = Name, reserved = False, value = value} = do

  this <- gets scope

  let t = def this ! value

  when (member value $ def this) $ do

    when (reserved t) $

      return ()

    when (arity t == Name) $

      error n "Unreserved is already defined."

  env <- get

  put env { scope = this {

    def = insert value n { reserved = True } $ def this

  } }



reserve _ = return ()



new_scope = do

  s <- gets scope

  let s' = Scope { def    = Map.empty,

                   parent = s }

  env <- get

  put env { scope = s' }

  return s'



advanceIf requiredId = do

  token <- gets token

  when (id token /= requiredId) $

    error token $ "Expected '" ++ requiredId ++ "'."

  advance



advance = do

  this <- get

  let (t, ts) = case tokens this of

        []

          -> (symbol_table this ! "(end)", [])

        t@(Token a v):tokens'

          -> let (o, a') = case a of

                   NameType

                     -> (find this $ v, Name)

                   OperatorType

                     -> case lookup v $ symbol_table this of

                          Just t' -> (t', Operator)

                          _       -> error t "Unknown operator."

                   NumberType

                     -> (symbol_table this ! "(literal)", Literal)

                   StringType

                     -> (symbol_table this ! "(literal)", Literal)

                   -- the next case can't happen and ghc throws a warning

                   -- _         -> error t "Unexpected token."

             in (o { value = v, arity = a' }, tokens')



  put this { token = t, tokens = ts }

  return t



expression rbp = do

  t <- gets token

  advance

  left <- nud t

  let walkRight left = do

        t <- gets token

        if rbp < lbp t then do

            advance

            left <- led t left

            walkRight left

          else return left

  walkRight left



type NudFun = This -> Parser Symbol

type LedFun = This -> Symbol -> Parser Symbol



statement = do

  n <- gets token

  case n of

    Symbol { std = Just std } -> do

      advance

      reserve n

      std n

    otherwise -> do

      v <- expression 0

      when (not (isAssignment v) && id v /= "(") $

        error v "Bad expression statement."

      advanceIf ";"

      return [v]



type StdFun = This -> Parser [Symbol]



-- For this function and all like it we don't change the return type

-- but instead make the pretty printer treat empty lists as null and

-- single element lists as the element.  To simplify the structure

-- of the Symbol data structure we also apply the equivilent

-- transformation there which means that single element lists appear

-- in many places where the Javascript uses just the element.

-- Because we apply this transformation uniformly there are cases

-- where our output is slightly different from the original.

statements = do

  token <- gets token

  if id token == "}" || id token == "(end)"

    then return []

    else do

      s <- statement

      ss <- statements

      return $ s ++ ss



block = do

  t <- gets token

  advanceIf "{"

  case std t of

    Just s -> s t



data Symbol = Symbol { id    :: Id,

                       arity :: Arity,

                       value :: Value,

                       lbp   :: BindingPower,

                       reserved, isAssignment :: Bool,

                       nudf  :: NudFun,

                       ledf  :: LedFun,

                       std   :: Maybe StdFun,

                       skope :: Scope,

                       key   :: Maybe Value,

                       first, second, third :: [Symbol] }



data Arity = Name | Operator | Literal | Unary | Binary | Ternary

           | Statement | This

           | Function { name :: Maybe Value }

           deriving (Eq, Show)



original_symbol = Symbol {

  nudf = \this   -> error this "Undefined.",

  ledf = \this _ -> error this "Missing operator.",

  std  = Nothing,

  first = [], second = [], third = [],

  id = undefined, arity = undefined, value = undefined, lbp = undefined,

  isAssignment = False, skope = undefined, reserved = False,

  key = Nothing

}



-- helper functions to access nudf/ledf with correct "object"

nud s = nudf s s

led s = ledf s s



symbol0 id = symbol1 id NilT

symbol1    = flip symbol 0



-- rather than make Symbol mutable this binds the function during

-- the symbol creation

-- symbol :: Id -> BindingPower -> SymbolType -> State SymbolTable Symbol

symbol id bp typ = do

  st <- get

  let s' = bind typ $

           case lookup id st of

             Just s -> if bp >= lbp s

                       then s { lbp = bp }

                       else s

             _ -> original_symbol { id    = id,

                                    value = id,

                                    lbp   = bp }

  put $ insert id s' st

  return s'

    where

      bind (Nud f) s = s { nudf = f }

      bind (Led f) s = s { ledf = f }

      bind (Std f) s = s { std  = Just f }

      bind _       s = s



data SymbolType = NilT 

                | Nud NudFun

                | Led LedFun

                | Std StdFun



-- this constant doesn't use the value because that would require a

-- datatype for all the kinds of javascript types it could be set to

constant0 s v = constant s v $ \this -> do

  reserve this

  symbol_table <- gets symbol_table

  return this { value = value $ symbol_table ! id this,

                arity = Literal }



constant s _ f = symbol1 s $ Nud f



-- infix is a keyword

inphix0 s bp = inphix s bp $ \this left -> do

  right <- expression bp

  return this { first  = [left],

                second = [right],

                arity  = Binary }



inphix s bp f = symbol s bp $ Led f



inphixr0 s bp = inphixr s bp $ \this left -> do

  right <- expression $ bp-1

  return this { first  = [left],

                second = [right],

                arity  = Binary }



-- infixr is a keyword

inphixr = inphix



assignment s = inphixr s 10 $ \this left -> do

  when (id left /= "." && id left /= "[" && arity left /= Name) $

    error left "Bad lvalue."

  right <- expression 9

  return this { first  = [left],

                second = [right],

                arity  = Binary,

                isAssignment = True }



-- prefix isn't a keyword but to named to match inphix and inphixr

prephix0 s = prephix s $ \this -> do

  reserve this

  expr <- expression 70

  return this { first = [expr],

                arity = Unary }



prephix s f = symbol1 s $ Nud f



stmt s f = symbol1 s $ Std f



initial_symbol_table = execState ist Map.empty

    where 

      ist = do



      symbol0 "(end)"

      symbol0 "(name)"



      symbol0 ":"

      symbol0 ";"

      symbol0 ")"

      symbol0 "]"

      symbol0 "}"

      symbol0 ","

      symbol0 "else"



      constant0 "true" True

      constant0 "false" False

      constant0 "null" undefined

      constant0 "pi" 3.141592653589793

      constant0 "Object" Map.empty

      constant0 "Array" []



      symbol1 "(literal)" $ Nud itself



      symbol1 "this" $ Nud $ \this -> do

        reserve this

        return this { arity = This }



      assignment "="

      assignment "+="

      assignment "-="



      inphix "?" 20 $ \this left -> do

        whenTrue <- expression 0

        advanceIf ":"

        whenFalse <- expression 0

        return this { first  = [left],

                      second = [whenTrue],

                      third  = [whenFalse],

                      arity  = Ternary }



      inphixr0 "&&" 30

      inphixr0 "||" 30



      inphixr0 "===" 40

      inphixr0 "!==" 40

      inphixr0 "<" 40

      inphixr0 "<=" 40

      inphixr0 ">" 40

      inphixr0 ">=" 40



      inphix0 "+" 50

      inphix0 "-" 50



      inphix0 "*" 60

      inphix0 "/" 60



      inphix "." 80 $ \this left -> do

        token <- gets token

        when (arity token /= Name) $

          error token "Expected a property name."

        -- Even though the Javascript updates the token it is then

        -- immediately discaded by 'advance' so we won't bother

        advance

        return this { first  = [left],

                      second = [token { arity = Literal }],

                      arity  = Binary }



      inphix "[" 80 $ \this left -> do

        s <- expression 0

        advanceIf "]"

        return this { first  = [left],

                      second = [s],

                      arity  = Binary }



      inphix "(" 80 $ \this left -> do

        t <- gets token

        a <- if id t /= ")" then

               let vars = do

                     e <- expression 0

                     token <- gets token

                     if id token /= ","

                       then return [e]

                       else do

                         advanceIf ","

                         v <- vars

                         return $ e:v

               in vars

             else return []

        -- can't use a before it's been populated

        let this' = if id left == "." || id left == "["

                    then this { first  = first left,

                                second = second left,

                                third  = a,

                                arity  = Ternary }

                    else if (arity left /= Unary || id left /= "function") &&

                            arity left /= Name && id left /= "(" &&

                            id left /= "&&" && id left /= "||" && id left /= "?"

                         then error left "Expected a variable name."

                         else this { first  = [left],

                                     second = a,

                                     arity  = Binary }

        advanceIf ")"

        return this'



      prephix0 "!"

      prephix0 "-"

      prephix0 "typeof"



      prephix "(" $ \this -> do

        e <- expression 0

        advanceIf ")"

        return e



      prephix "function" $ \this -> do

        new_scope

        t <- gets token

        n <- if arity t == Name then do

               define t

               advance

               return $ Just $ value t

             else return Nothing

        t <- advanceIf "("

        a <- if id t /= ")" then

               let params = do

                     t <- gets token

                     when (arity t /= Name) $

                       error t "Expected a parameter name."

                     define t

                     token <- advance

                     if id token /= ","

                       then return [t]

                       else do

                         advanceIf ","

                         p <- params

                         return $ t:p

               in params

             else return []

        advanceIf ")"

        advanceIf "{"

        s <- statements

        advanceIf "}"

        pop

        return this { first  = a,

                      second = s,

                      arity  = Function { name = n } }



      prephix "[" $ \this -> do

        t <- gets token

        a <- if id t /= "]" then

               let entries = do

                     v <- expression 0

                     token <- gets token

                     if id token /= ","

                       then return [v]

                       else do

                         advanceIf ","

                         e <- entries

                         return $ v:e

               in entries

             else return []

        advanceIf "]"

        return this { first = a,

                      arity = Unary }



      prephix "{" $ \this -> do

        t <- gets token

        a <- if id t /= "}" then

               let entries = do

                     n <- gets token

                     when (arity n /= Name && arity n /= Literal) $

                       error n "Bad property name."

                     advance

                     advanceIf ":"

                     v <- expression 0

                     let v' = v { key = Just $ value n }

                     token <- gets token

                     if id token /= ","

                       then return [v']

                       else do

                         advanceIf ","

                         e <- entries

                         return $ v':e

               in entries

             else return []

        advanceIf "}"

        return this { first = a, 

                      arity = Unary }



      stmt "{" $ \this -> do

        new_scope

        a <- statements

        advanceIf "}"

        pop

        return a



      stmt "var" $ \this -> do

        let vars = do

              n <- gets token

              when (arity n /= Name) $

                error n "Expected a new variable name."

              define n

              t <- advance

              a <- if id t == "=" then do

                     advanceIf "="

                     s <- expression 0

                     let t' = t { first  = [n],

                                  second = [s],

                                  arity  = Binary,

                                  isAssignment = True }

                     return [t']

                   else return []

              t <- gets token

              if id t /= ","

                then return a

                else do

                  advanceIf ","

                  v <- vars

                  return $ a++v



        a <- vars

        advanceIf ";"

        return a



      stmt "if" $ \this -> do

        advanceIf "("

        test <- expression 0

        advanceIf ")"

        body <- block

        token <- gets token

        els <- if id token == "else" then do

                 reserve token

                 token <- advanceIf "else"

                 if id token == "if" then statement else block

               else return []

        return [this { first  = [test],

                       second = body,

                       third  = els,

                       arity  = Statement }]



      stmt "return" $ \this -> do

        t <- gets token

        first <- if id t /= ";" then do

                   e <- expression 0

                   return [e]

                 else return []

        t <- advanceIf ";"

        when (id t /= "}") $

          error t "Unreachable statement."

        return [this { first = first,

                       arity = Statement }]



      stmt "break" $ \this -> do

        t <- advanceIf ";"

        when (id t /= "}") $

          error t "Unreachable statement."

        return [this { arity = Statement }]



      stmt "while" $ \this -> do

        advanceIf "("

        f <- expression 0

        advanceIf ")"

        s <- block

        return [this { first  = [f],

                       second = s,

                       arity  = Statement }]



parse source = 

  evalState ( do

    new_scope

    advance

    s <- statements

    advanceIf "(end)"

    return s

  ) Env { tokens       = tokenise source,

          scope        = TopScope,

          token        = original_symbol { id = "(start)" },

          symbol_table = initial_symbol_table }



type Value        = String

type Id           = String

type BindingPower = Int

type This         = Symbol



error t msg = Prelude.error $ msg ++ " " ++ show t



instance Show Symbol where

    show Symbol { value = value, arity = arity } =

      "{value: " ++ show value ++ " " ++ show arity ++ "}"



module Tokeniser where



import Text.Read (lex)

import Data.Char (isAlpha, isNumber)



data Token     = Token TokenType String

                 deriving Show

data TokenType = NameType | StringType | NumberType | OperatorType

                 deriving Show



tokenise = tokens . head . lex

    where

      tokens (t, "") = [token t]

      tokens (t, s)  =  token t : tokenise s



      token t@(c:_) = Token tokenType text

          where

            tokenType | isAlpha  c = NameType     

                      | isNumber c = NumberType   

                      | '"' ==   c = StringType

                      | otherwise  = OperatorType 



            text | c == '"'  = drop 1 $ take (length t-1) t

                 | otherwise = t



      token _ = Token OperatorType "(end)"



module PrettyPrint where



import Text.PrettyPrint



import TopDownParserState



pp = ppList ""



ppList l []     = empty

ppList l (s:[]) = ppSymbol l s

ppList l s      = bracket l $

                    vcat $ map (ppSymbol "") s



ppSymbol l Symbol {key = k, value = v, arity = a,

                   first = f, second = s, third = t } =

    brace l $

      ppMaybe "key: " k $$

      ppValue v $$

      ppArity a $$

      ppList "first: " f $$

      ppList "second: " s $$

      ppList "third: " t



ppMaybe l (Just k) = text l <> textOf k

ppMaybe l Nothing  = empty



ppValue v = text "value: " <> textOf v



ppArity a@Function {name = n} =

    text "arity: Function" $$

    ppMaybe "name: " n

ppArity a = text "arity: " <> textOf a



textOf :: Show a => a -> Doc

textOf = text . show



bracket l s = (text l <> lbrack) $+$ indent s $$ rbrack

brace   l s = (text l <> lbrace) $+$ indent s $$ rbrace



indent = nest 4

Haskell Regular Expression Matcher

DRMacIver (David R. MacIver) — Sun, 19 Aug 2007 20:57:56 GMT

Basic implementation of Regular Expressions based on "Derivatives of Regular Expressions" by Janusz A. Brzozowski (Journal of Association for Computing Machinery, October 1964)

Not really intended for serious use. Just a proof of concept.



module Regexp

where



import Data.Set (Set)

import Data.Map (Map)

import Monad

import List

import Maybe

import qualified Data.Set as Set

import qualified Data.Map as Map



data Regexp = 

    Zero

  | Match Char       -- matches a single char

  | Not Regexp       -- matches the negation of its argument

  | Prod [Regexp]    -- matches a concatentation of its arguments

  | Sum (Set Regexp) -- matches either of its arguments

  | Star Regexp      -- matches repetitions of its argument (including 0 repetitions)

  deriving (Eq, Ord)



instance Show Regexp where

  show Zero = "0"

  show (Match c) = [c]

  show (Not x)   = '~' : show x

  show (Prod x) = join . (map show)  $ x

  show (Sum x) = "(" ++ ( join . intersperse "|" . (map show) . Set.toList $ x ) ++ ")"

  show (Star x) = "(" ++ show x ++ ")*" 



-- Flagrant abuse of type classes to allow implicit conversion of datatypes into regular

-- expressions.

class Match a where

  match :: a -> Regexp



instance Match Char where

  match c = Match c



instance (Match a) => Match [a] where

  match = con



instance Match Regexp where

  match = id



-- "smart" versions of the constructors, which perform normalisation of the datatype.

-- As long as all regular expressions are built up using these and the match instance

-- for char we can guarantee that structural equality of terms == similarity.

-- This is important to make sure we only generate a finite number of states.

zero :: Regexp 

zero = Zero 



one :: Regexp

one = Prod []



(<+>) :: (Match a, Match b) => a -> b -> Regexp

x <+> y = 

  case (match x, match y) of

    (Zero, b)      -> b

    (a, Zero)      -> a

    (Sum a, Sum b) -> Sum (Set.union a b)

    (Sum a, b)     -> Sum (Set.insert b a)

    (a, Sum b)     -> Sum (Set.insert a b)    

    (a, b)         -> Sum $ Set.fromList [a, b]

  

oneOf :: (Match a) => [a] -> Regexp

oneOf = foldr (<+>) zero



(<*>) :: (Match a, Match b) => a -> b -> Regexp

u <*> v = 

  case (match u, match v) of 

    (Zero, _)         -> zero

    (_, Zero)         -> zero

    (Prod x, Prod y)  -> Prod (x ++ y)

    (Prod x, y)       -> Prod (x ++ [y])

    (x, Prod y)       -> Prod (x : y)

    (x, y)            -> Prod [x, y]



con :: (Match a) => [a] -> Regexp

con = foldr (<*>) one



neg :: (Match a) => a -> Regexp

neg x = 

  case (match x) of

  (Not y) -> y

  y       -> Not y



star :: (Match a) => a -> Regexp

star x =

  case (match x) of

    (Zero)   -> Zero

    (Star y) -> Star y

    y        -> Star y



-- Returns if the regex matches the empty string.

del :: Regexp -> Bool

del (Zero)    = False

del (Sum x)   = or . map del $ Set.toList x

del (Prod x)  = and . map del $ x

del (Match _) = False

del (Not x)   = not $ del x;

del (Star _)  = True



-- The derivative of a regular language A with respect to a character

-- c is dA/dc = { s : cs \in A } 

diff :: Char -> Regexp -> Regexp

diff _ (Zero)  = zero

diff c (Match d) | (c == d) = one

diff c (Match d) = zero

diff c (Sum x) = oneOf $ (map $ diff c) (Set.toList x)

diff c (Prod []) = zero

diff c (Prod (x:xs)) | del x = (diff c x <*> xs) <+> diff c (Prod xs)

diff c (Prod (x:xs)) = diff c x <*> xs

diff c (Not x) = Not (diff c x)

diff c (Star x) = diff c x <*> Star x



flattenSet :: (Ord a) => Set (Set a) -> Set a

flattenSet = Set.fold Set.union Set.empty



(/>>=) :: (Ord a, Ord b) => Set a -> (a -> Set b) -> Set b

x />>= f = flattenSet (Set.map f x)



-- The alphabet of all characters that appear in this regexp

alphabet :: Regexp -> Set Char

alphabet (Zero) = Set.empty

alphabet (Sum x) = flattenSet (Set.map alphabet x) 

alphabet (Prod x) = Set.unions $ map alphabet x

alphabet (Not x) = alphabet x

alphabet (Star x) = alphabet x

alphabet (Match c) = Set.singleton c



-- Set of all derivatives of a regular expression (including itself, and higher order derivatives).

derivatives :: Regexp -> [Regexp]

derivatives exp = Set.toList $ enlarge (Set.singleton exp) (Set.singleton exp) 

  where

    alpha = alphabet exp

    firstDerivatives x = Set.map (`diff` x) alpha 

    enlarge :: Set Regexp -> Set Regexp -> Set Regexp

    enlarge new found = 

      if Set.null new

        then found

        else

          let nextNew   = (new />>= firstDerivatives) Set.\\ found

              nextFound = found `Set.union` nextNew

          in enlarge nextNew nextFound



-- A simple finite state machine type 

data FSM = State { transitions :: (Map Char FSM), isFinal :: Bool } 



-- Converts a Regexp into a finite state machine by using the derivatives

-- with respect to specific characters as the transitions. Essentially at 

-- each stage we build up a regular expression that the remaining characters

-- have to match. Due to Cunning Mathematics, only finitely many such regular

-- expressions (up to similarity) result.

compile :: Regexp -> FSM

compile x = fromJust $ Map.lookup x states

  where

    states :: Map Regexp FSM

    states = Map.fromList $

      do re <- derivatives x -- Totally gratuitious use of list monad. :)

         let trans = do c <- Set.toList $ alphabet re

                        let d = diff c re

                        return (c, fromJust $ Map.lookup d states)

         let state = State (Map.fromList trans) (del re) 

         return (re, state) 



runFSM :: FSM -> String -> Bool

runFSM x []     = isFinal x

runFSM x (c:cs) = case (Map.lookup c $ transitions x) of

                    Nothing -> False

                    Just y  -> runFSM y cs

               

matches :: (Match a) => String -> a -> Bool

matches cs exp = runFSM (compile $  match exp) cs

Simple Haskell script for word counting

DRMacIver (David R. MacIver) — Thu, 05 Jul 2007 13:52:45 GMT

This is just a simple piece of code I put together to play with some Haskell when I realised I've not been writing nearly enough of the stuff.

It reads text from stdin and prints the words it finds together with how many times each one occurred.



module Main

where



import List

import Control.Arrow



type Comparator a = (a -> a -> Ordering)



ascending :: (Ord a) => (b -> a) -> Comparator b

ascending f x y = compare (f x) (f y)



descending :: (Ord a) => (b -> a) -> Comparator b

descending = flip . ascending



secondary :: Comparator a -> Comparator a -> Comparator a

secondary f g x y = case f x y of {

                    EQ -> g x y;

                    z  -> z; }



-- Returns a list of unique elements together with their frequency. Listed in decreasing order of frequency, followed by

increasing order of the elements.

count :: (Ord a) => [a] -> [(a, Int)]

count = map (head &&& length) . sortBy (descending length `secondary` ascending head) . group . sort



main :: IO ()

main = interact $ unlines . map (\(x, y) -> (take 20 $ x ++ repeat ' ')  ++ " : " ++ show y) . count . words

Putlines in Haskell

DRMacIver (David R. MacIver) — Sat, 12 May 2007 15:17:04 GMT

This is an illustrative example of

a) Point free style
b) How Haskell IO works.

If you don't understand Haskell IO, it might be helpful to try and unpick the definition here to see how it works. :-)



import System



main :: IO ()

main = getArgs >>= sequence_ . (map putStrLn)

JSON Parser in Haskell

DRMacIver (David R. MacIver) — Sun, 11 Mar 2007 14:52:38 GMT

I've been having trouble writing parsers recently, and I've been meaning to get to grips with Haskell at some point, so I figured I'd write a simple JSON parser using Haskell's Parsec library. Here's the code for it:

Update: I've modified this to use Data.Map instead of a list of key value pairs for the record / object implementation. I've also removed the 'identifier' feature as it isn't really part of JSON proper. Also, I've noticed that this seems to have acquired some sort of presence on google. This isn't really very good code - it's more a demonstration of parsec than it is an actually useful parser. (I mean, it works fine, and it's probably sufficient for trivial uses, but I wouldn't e.g. guarantee it to be bug free). I strongly recommend using this one instead.



import Text.ParserCombinators.Parsec

import System

import qualified Data.Map as Map



-- Main method. Currently not very interesting - just a test piece of code which accepts

-- a file and prints out a representation of the parsed type (or an error message if it is

-- invalid.

mainParser = do {

    val <- valueParser

    ; skipMany space

    ; eof

    ; return val }



main :: IO ()

main = do {

    args <- getArgs 

  ; val <- parseFromFile mainParser $ args !! 0 

  ; print(val) } 



-- Matches string literals. 

literalString :: Parser JSON 

literalString = do {

        char '"'

      ;  val <-  many1 letter

      ;  char '"'

      ; return $ LiteralString val}





-- Data type representing a JSON AST. Roughly corresponds to a Javascript object.

data JSON = ListValue [JSON] 

          | LiteralString String

          | LiteralInt Integer

          | LiteralBoolean Bool

          | RecordValue (Map.Map String JSON)

            deriving Show         





-- Combined parser.

valueParser :: Parser JSON

valueParser =       

        literalString

    <|> literalInt

    <|> literalBoolean

    <|> recordParser

    <|> listParser 



-- Matches literal integers.

literalInt :: Parser JSON

literalInt = do {

    ; val <- many1 digit

    ; return $ LiteralInt (read val)

        }



-- Matches boolean literals

literalBoolean :: Parser JSON

literalBoolean =

                do{ 

                  string "true"

                ; return $ LiteralBoolean True}

            <|> do{

                  string "false"

                ; return $ LiteralBoolean False}



-- Code for parsing lists.

-- Matches comma separated lists enclosed in [ ]

listParser :: Parser JSON 

listParser = do{ 

                char '['

              ; words <- sepBy1 valueParser listSeparator

              ; char ']'

              ; return $ ListValue words

              }



-- Matches ',' with any amount of space on either side.

listSeparator :: Parser ()

listSeparator = do{ 

      skipMany space 

    ; char ','

    ; skipMany space

}



-- Code for parsing records.

-- Matches { word : JSON; word : JSON; word : value; ... }

recordParser :: Parser JSON 

recordParser = do{

      char '{'

    ; defs <- endBy definitionParser definitionSeparator

    ; char '}'

    ; return $ RecordValue $ Map.fromList defs 

}



-- Matches things of the form word : JSON

definitionParser :: Parser (String, JSON)

definitionParser = do{

      skipMany space

    ; key <- many1 letter 

    ; skipMany space

    ; char ':'

    ; skipMany space

    ; val <- valueParser

    ; return (key, val)

}



-- Matches ';' with any amount of space on either side.

definitionSeparator :: Parser ()

definitionSeparator = do {

      skipMany space

    ; char ';'

    ; skipMany space

    ; return () 

}

<- and let .. = confusion

Dino () — Thu, 01 Jun 2006 18:10:33 GMT

// description of your code here



module Main

   where



import Random





main = do

   -- Either of these work

   --rnum <- oneRandNum

   let rnum = oneRandNum



   -- But only let works here. Why?

   --numbers <- randArray

   let numbers = randArray



   -- Required for successful compilation.

   print "foo"





oneRandNum :: IO Int

oneRandNum = getStdRandom( randomR( 0, 9 ) )



randArray :: [IO Int]

randArray = [oneRandNum]