-- | Main entry point. Takes in Haskell Show instances in standard
-- input and outputs s-expressions.

module Main where

import Control.Arrow
import Data.List
import Text.Show.Pretty

-- | Main entry point.
main :: IO ()
main = interact convert

-- | Convert Haskell syntax to s-expression.
convert :: String -> String
convert code = do
  case parseValue code of
    Nothing -> printSexp (SCons (SAtom "arbitrary") (SString (show code)))
    Just value -> printSexp (valueToSexp value)

-- | An s-expression.
data Sexp
  = SAtom String
  | SString String
  | SList [Sexp]
  | SCons Sexp Sexp
  deriving Show

-- | Convert a value to an s-expression.
valueToSexp :: Value -> Sexp
valueToSexp value =
  case value of
    Con name values -> SCons (SAtom "data")
                             (SCons (SAtom (show name))
                                    (SList (map valueToSexp values)))
    Rec name fields -> SCons (SAtom "record")
                             (SCons (SAtom (show name))
                                    (SList (map (\(name,value) -> SCons (SAtom (show name))
                                                                        (valueToSexp value))
                                                fields)))
    Tuple values -> SCons (SAtom "tuple")
                          (SList (map valueToSexp values))
    List values -> SCons (SAtom "list")
                         (SList (map valueToSexp values))
    Neg value -> valueToSexp (Integer ("-" ++ printSexp (valueToSexp value)))
    Ratio n d -> valueToSexp (Integer (printSexp (valueToSexp n) ++
                                       "/" ++
                                       printSexp (valueToSexp d)))
    Integer i -> SCons (SAtom "num") (SAtom i)
    Float i -> SCons (SAtom "num") (SAtom i)
    Char i -> SCons (SAtom "char")
                    (SAtom ("?" ++ [read i :: Char]))
    String s -> SCons (SAtom "string") (SString (show (stripQuotes s)))

-- | For some reason the parsing of strings in parseValue is stupid.
stripQuotes :: String -> String
stripQuotes ('"':rest) = go rest where
  go ['"'] = []
  go (x:xs) = x : go xs

-- | Print an s-expression to a string.
printSexp :: Sexp -> String
printSexp sexp =
  case sexp of
    SAtom i -> i
    SString s -> s
    SList xs -> "(" ++ intercalate " " (map printSexp xs) ++ ")"
    SCons x y -> "(" ++ printSexp x ++ " . " ++ printSexp y ++ ")"

-- | Run the test cases.
runtests :: IO ()
runtests = if all id results
              then putStrLn "OK."
              else putStrLn $ "TEST FAILED\n===========\n" ++ 
                   case head (map result (filter (not . test) tests)) of
                     ((input,expected),given) ->
                       intercalate "\n" ["Input:    " ++ input
                                        ,"Expected: " ++ expected
                                        ,"Given:    " ++ given]
  where results = map test tests
        test (given,expected) = convert given == expected
        result = id &&& convert . fst

-- | The test cases.
tests :: [(String,String)]
tests =
  [("(A)","(data . (\"A\" . ()))")
  ,("A","(data . (\"A\" . ()))")
  ,("Bar","(data . (\"Bar\" . ()))")
  ,("Bar (Mu)","(data . (\"Bar\" . ((data . (\"Mu\" . ())))))")
  ,("1","(num . 1)")
  ,("/+0-'24","(arbitrary . \"/+0-'24\")")
  ,("'a'","(char . ?a)")
  ,("'\\''","(char . ?')")
--  ,(":+","(data . (\":+\" . ()))") -- TODO:
  ,("1.1","(num . 1.1)")
  ,("\"string\"","(string . \"string\")")
  ,("\"st\\\"ring\"","(string . \"st\\\"ring\")")
  ,("\"str\\265ing\"","(string . \"str\\265ing\")")
  ,("[6,9]","(list . ((num . 6) (num . 9)))")
  ,("[6,[A,B]]","(list . ((num . 6) (list . ((data . (\"A\" . ())) (data . (\"B\" . ()))))))")
  ,("[A,B]","(list . ((data . (\"A\" . ())) (data . (\"B\" . ()))))")
  ,("(1,2)","(tuple . ((num . 1) (num . 2)))")
  ,("[(1,2),(3,4)]","(list . ((tuple . ((num . 1) (num . 2))) (tuple . ((num . 3) (num . 4)))))")
  ,("Foo {fooX = 1}","(record . (\"Foo\" . ((\"fooX\" . (num . 1)))))")
  ,("Foo {fooX = 1, fooY_ = A, fooZ1 = Foo, fooA' = [1,2], fooB = (1,2), fooC = [A,(B,\"C\")]}",
     "(record . (\"Foo\" . ((\"fooX\" . (num . 1)) (\"fooY_\" . (data . (\"A\" . ()))) (\"fooZ1\" . (data . (\"Foo\" . ()))) (\"fooA'\" . (list . ((num . 1) (num . 2)))) (\"fooB\" . (tuple . ((num . 1) (num . 2)))) (\"fooC\" . (list . ((data . (\"A\" . ())) (tuple . ((data . (\"B\" . ())) (string . \"C\")))))))))")]