{-

        / \
      /     \
     |\     / \ / \  chiral software
     |  \ /     \   \
      \  |\     /|  /|
        \|  \ /  |/  |
         |\  |  /|  /
         |  \|/  |/
          \  |  /
            \|/
-}

module Dendra(
  Dendra(..),
  isInt, isDouble, isString, isSymbol, isText, isList, 
  isNull, isDict, sameType,
  intVal, doubleVal, textVal, listVal, dictVal,
  parseList, parseDendra, printDendra, 
  toDictForm, fromDictForm, buildDict, hasVal
  ) where

import Char

import Dict

-- hide from HUGS
fromInt = fromIntegral

-- data type

data Dendra =
    DendraInt    Int
  | DendraDouble Double
  | DendraString String
  | DendraSymbol String
  | DendraList   [Dendra]
  | DendraDict   (Dict String Dendra)
  | DendraNull 
    deriving (Read, Show)

isInt, isDouble, isString, isNull :: Dendra -> Bool
isSymbol, isText, isDict, isList  :: Dendra -> Bool
sameType :: Dendra -> Dendra -> Bool

intVal      :: Dendra -> Int
doubleVal   :: Dendra -> Double
textVal     :: Dendra -> String
listVal     :: Dendra -> [Dendra]
dictVal     :: Dendra -> Dict String Dendra

parseDendra  :: String -> (Dendra,String)
parseList    :: String -> (Dendra,String)
printDendra  :: Dendra -> String

toDictForm   :: Dendra -> Dendra
fromDictForm :: Dendra -> Dendra
buildDict    :: [Dendra] -> Dendra
hasVal       :: Dict String Dendra -> String -> Dendra -> Bool

isInt d    = case d of { (DendraInt i) -> True; _ -> False }
isDouble d = case d of { (DendraDouble d) -> True; _ -> False }
isString d = case d of { (DendraString s) -> True; _ -> False }
isSymbol d = case d of { (DendraSymbol s) -> True; _ -> False }
isText d   = isString d || isSymbol d
isList d   = case d of { (DendraList ds) -> True; _ -> False }
isDict d   = case d of { (DendraDict d) -> True; _ -> False }
isNull d   = case d of { DendraNull -> True; _ -> False }
sameType (DendraInt i) (DendraInt j) = True
sameType (DendraDouble d) (DendraDouble e) = True
sameType (DendraString s) (DendraString t) = True
sameType (DendraSymbol s) (DendraSymbol t) = True
sameType (DendraList l) (DendraList m) = True
sameType (DendraDict d) (DendraDict e) = True
sameType DendraNull DendraNull = True
sameType _ _ = False

intVal    (DendraInt i)    = i
doubleVal (DendraDouble d) = d
textVal   (DendraString s) = s
textVal   (DendraSymbol s) = s
listVal   (DendraList ds)  = ds
dictVal   (DendraDict d)   = d

-- parser

parseDendra = (maybe noParse id) . parseDendra'

parseDendra' = parseS
  parseSpace
  (parseAL [
    pTrans parseList' DendraList,
    pTrans parseString DendraString,
    pTrans parseFloat DendraDouble,
    pTrans parseInt DendraInt,
    pTrans parseSymbol DendraSymbol
    ])
  (flip const)

noParse = (DendraNull,[])

parseList = (maybe noParse (\(x,s)->(DendraList x,s))) . parseList'

-- Space
-- NOTE we are using ';' and "{}" comments

parseSpace = parseF () 
  (parseA
    (parseC isSpace (const ()),id)
    (parseComment,id))
  const

parseComment = parseA (parseEOLComment,id) (parseBlockComment,id)

parseEOLComment = parseS
  (parseK ";" ())
  (parseF () (parseC (/= '\n') (const ())) const)
  const

parseBlockComment = parseS
  (parseK "{" ())
  (parseS
    (parseF () parseToken const)
    (parseS parseSpace (parseK "}" ()) const)
    const)
  const

parseToken = parseS
  (parseO parseSpace () id)
  (parseAL [
    pTrans parseString (const ()), 
    pTrans parseFloat (const ()), 
    pTrans parseInt (const ()),
    pTrans parseSymbol (const ()),
    parseK ")" (), 
    parseK "(" ()])
  const

-- Lists

parseList' = parseS
  (parseK "(" ())
  (parseS
    (parseF [] parseDendra' snoc)
    (parseS parseSpace (parseK ")" ()) const)
    const)
  (flip const)

-- Strings

parseString = parseS
  (parseK "\"" ())
  (parseS
    (parseF [] (parseA (parseStrChr,id) (parseEscChar,id)) (++))
    (parseK "\"" ())
    const)
  (flip const)

parseStrChr = parseC (\c->c /= '"' && c /= '\\') single

parseEscChar = parseS
  (parseK "\\" ())
  (parseAL [
    parseC (== '\n') (const []),
    parseC (`elem` specialChar) single,
    parseEscCode ])
  (flip const)

specialChar = "{};()\\\""

parseEscCode = 
  (maybe Nothing (\(i,s)->Just ([chr (i `mod` 256)],s))). parseDec
  
-- Ints

parseInt = parseS (parseO parseSign 1 id) parseDec (*)

parseDec = parseG
  parseDigit
  (parseF 0 parseDigit (\o n->10*o+n))

parseDigit = parseC isDigit digitToInt

parseSign = parseA 
  (parseC (== '+') (const (1::Int)),id)
  (parseC (== '-') (const (-1::Int)),id)
 
-- Doubles

parseFloat = parseS 
  (parseO parseSign 1 id)
  (parseS
    parseDecimal (parseO parseExp 0 id) (\m e->m*10^^e))
  (\s v->(fromIntegral s)*v)

parseDecimal = parseS
  (parseS parseDDec (parseK "." 0) const) 
  (pTrans parseDFrac snd) (+)
    
parseDDec = parseG
  (pTrans parseDigit (const 0.0))
  (parseF 0.0 parseDigit (\o n->10.0*o+(fromIntegral n)))

parseDFrac = parseG
  (pTrans parseDigit (const (0.0,0.0)))
  (parseF (0.1,0.0) parseDigit 
    (\(op,or) n->(op/10.0,or+op*(fromIntegral n))))
  
parseExp = parseS
  (parseA (parseK "e" 0,id) (parseK "E" 0,id))
  parseInt (flip const)
   
-- Symbols (assuming numbers have already been parsed)

parseSymbol = parseS
  parseSymChar (parseF [] parseSymChar (++)) (++)

parseSymChar = parseA (parseEscChar,id) (parseC isSymChar single,id)
  
isSymChar cc = 
  isPrint cc && cc /= ' ' && (not (cc `elem` specialChar))
  
-- printer

printDendra (DendraList l) = '(' : printList l
printDendra (DendraInt i) = show i
printDendra (DendraDouble d) = show d
printDendra (DendraString s) = "\"" ++ concat (map (escape "\\\"") s) ++ "\""
printDendra (DendraSymbol s) = concat (map escapeSymChar s)

printList [] = ")"
printList [d] = printDendra d ++ ")"
printList (d:ds) = printDendra d ++ " " ++ printList ds

escape ecs c = if c `elem` ecs then '\\' : [c] else [c]
escapeSymChar c = 
  if c `elem` specialChar then '\\':[c] else
  if c == ' ' || not (isPrint c) then "\\"++(show (ord c)) else
  [c]
 
-- Dictionary stuff

toDictForm (DendraList [DendraSymbol "sym",DendraSymbol s]) =
  DendraSymbol s
toDictForm (DendraList ((DendraString "dict"):defs)) = buildDict defs
toDictForm (DendraList ((DendraSymbol "dict"):defs)) = buildDict defs
toDictForm (DendraList xs) = DendraList (map toDictForm xs)
toDictForm x = x

buildDict = buildDict' empty where
  buildDict' d [] = DendraDict d
  buildDict' d (k:(v:ds)) = buildDict' (d `put` 
    (textVal k,toDictForm v)) ds

fromDictForm (DendraList [DendraSymbol "sym",DendraSymbol s]) =
  DendraList [DendraList [symEsc,symEsc],DendraSymbol s]
fromDictForm (DendraDict d) = DendraList ((DendraSymbol "dict"):
  concat [[DendraString k,fromDictForm v] | (k,v) <- listDict d])
fromDictForm (DendraList xs) = DendraList (map fromDictForm xs)
fromDictForm x = x

symEsc = DendraSymbol "sym"

hasVal d k t = case d `look` k of
  Just (k,v) -> v `sameType` t
  Nothing -> False

{-
module ParserCombinators(
  Parser,
  parseO, parseS, parseA, parseC, parseK, parseG,
  parseF, parseAL) where
-}

type Parser a = String -> Maybe (a,String)
parseO :: Parser a -> b -> (a -> b) -> Parser b
parseS :: Parser a -> Parser b -> (a -> b -> c) -> Parser c
parseA :: (Parser a, a -> c) -> (Parser b , b -> c) -> Parser c
parseC :: (Char -> Bool) -> (Char -> a) -> Parser a
parseK :: String -> a -> Parser a
parseF :: b -> Parser a -> (b -> a -> b) -> Parser b
parseG :: Parser a -> Parser a -> Parser a
parseAL :: [Parser a] -> Parser a
pTrans :: Parser a -> (a -> b) -> Parser b


parseO pa z f s = maybe (Just (z,s)) phase1 (pa s) where
  phase1 (a,t) = Just (f a,t)

parseS pa pb f s = phase1 where
  phase1 = maybe Nothing phase2 (pa s) where
    phase2 (a,t) = maybe Nothing phase3 (pb t) where
      phase3 (b,u) = Just (f a b,u)
        
parseA (pa,af) (pb,bf) s = phase1 where
  phase1 = maybe phase2 phase3 (pa s) where
    phase3 (a,t) = Just (af a,t)
    phase2 = maybe Nothing phase4 (pb s) where
      phase4 (b,u) = Just (bf b,u)
      
parseC p f [] = Nothing
parseC p f (c:cs) = if p c then Just (f c,cs) else Nothing

parseK k z s = 
  if isPrefix k s 
  then Just (z,drop (length k) s) 
  else Nothing
  
parseF z p f s = maybe (Just (z,s)) phase2 (p s) where
  phase2 (a,t) = parseF (f z a) p f t
  
parseG g f s = maybe Nothing (const (f s)) (g s)

parseAL = foldl1 (\p1 p2->parseA (p1,id) (p2,id))
  
pTrans p f s = maybe Nothing (\(x,t)->Just (f x,t)) (p s)

isPrefix [] s = True
isPrefix (c:cs) [] = False
isPrefix (k:ks) (s:ss) = k == s && isPrefix ks ss

-- Somehow missing from Hugs98

integerLogBase :: Integer -> Integer -> Int
integerLogBase b i =
  if i < b 
  then 0
  else
    let 
      l = 2 * integerLogBase (b*b) i
      doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
    in doDiv (i `div` (b^l)) l

snoc xs x = xs ++ [x]
single x = [x]