content: {-# LANGUAGE LambdaCase #-}
  
  module LispLovesMe where
  
  import Data.List
  import Data.Maybe
  import Text.ParserCombinators.ReadP
  
  data AST = I32 Int
           | Sym String
           | Nul
           | Err
           | Lst [AST]
           | Boo Bool
           | Nod AST [AST]
           deriving (Eq, Show)
  --
  
  expr = symbols
     +++ numbers
     +++ booleans
     +++ nulls
     +++ nodes
  
  nodes = do
     char '('
     whiteSpace
     fist <- expr
     exprs <- many expr
     char ')'
     whiteSpace
     return $ Nod fist exprs
  
  nulls = (const Nul <$> string "null" <* whiteSpace) +++ nul
    where
      nul = do
          char '('
          whiteSpace
          char ')'
          whiteSpace
          return Nul
  
  booleans = Boo <$> choice [ const True <$> string "true", const False <$> string "false" ] <* whiteSpace
  numbers = I32 . read <$> munch1 (`elem` ['0'..'9']) <* whiteSpace
  
  symbols = do
    fist <- satisfy (`notElem` (" ,\n\t\r()" ++ [ '0' .. '9' ]))
    tal <- munch (`notElem` " ,\n\t\r()") <* whiteSpace
    let sym = fist : tal
    if sym `notElem` [ "true", "false", "null" ]
      then return $ Sym sym
      else pfail
  
  whiteSpace = many $ satisfy (`elem`",\r\n\t ")
  
  eval :: AST -> AST
  eval (Nod (Sym fist) param) =
      if err
         then Err
         else fromMaybe Err $ ($ ps') <$> lookup fist preludeFunctions
    where
      ps' = fmap eval param
      err = any (\case Err -> True; _ -> False) ps'
  eval (Nod _ _) = Err
  eval x = x
  
  preludeFunctions :: [(String, [AST] -> AST)]
  preludeFunctions =
    [ ("+", checkErr (op (+)))
    , ("*", checkErr (op (*)))
    , ("-", checkErr (op (-)))
    , ("/", checkErr (op div))
    , ("^", \ps -> if length ps == 2 then checkErr (op (^)) ps else Err)
    , (">", \ps -> if length ps == 2 then checkErr (op2bb (>)) ps else Err)
    , ("<", \ps -> if length ps == 2 then checkErr (op2bb (<)) ps else Err)
    , ("!", \ps -> if length ps == 1
                     then case eval $ head ps of
                       Boo b -> Boo $ not b
                       _     -> Err
                     else Err)
    , ("list", checkErr Lst)
    , ("size", checkErr size)
    , ("reverse", checkErr reverse')
    , ("..", checkErr range)
    , ("==", \ps -> if length ps == 2 then checkErr (op2bb (==)) ps else Err)
    , (">=", \ps -> if length ps == 2 then checkErr (op2bb (>=)) ps else Err)
    , ("<=", \ps -> if length ps == 2 then checkErr (op2bb (<=)) ps else Err)
    , ("!=", \ps -> if length ps == 2 then checkErr (op2bb (/=)) ps else Err)
    , ("if", if')
    ]
    where
      checkErr f ps = if err then Err else f ps'
        where
          ps' = fmap eval ps
          err = any (\case Err -> True; _ -> False) ps'
      op f [] = Err
      op f ps = if any (\case I32 x -> False; _ -> True ) prs
                  then Err
                  else I32 $ foldl1 f ps'
        where
          prs = eval <$> ps
          ps' = (\case I32 v -> v) <$> prs
      op2bb f [I32 a, I32 b] = Boo $ f a b
      op2bb _ _              = Err
      reverse' [Lst x] = Lst $ reverse x
      reverse' _       = Err
      range [I32 a, I32 b] = Lst $ I32 <$> [a..b]
      range _              = Err
      if' (p : a : b) = case p' of
          Boo x -> if x then eval a else case b of
            [ ] -> Nul
            [x] -> eval x
            _   -> Err
          _     -> Err
        where p' = eval p
      if' _             = Err
      size [Lst ls] = I32 $ length ls
      size _        = Err
  --
  pretty :: AST -> String
  pretty (I32 xs)    = show xs
  pretty (Nod a b)   = "(" ++ unwords (pretty <$> (a:b)) ++ ")"
  pretty (Sym s)     = s
  pretty Nul         = "null"
  pretty (Boo True)  = "true"
  pretty (Boo False) = "false"
  
  lispPretty :: String -> Maybe String
  lispPretty s = case filter ((== "") . snd) $ readP_to_S expr $ trimH s of
    [] -> Nothing
    xs -> Just $ pretty $ fst $ last xs
  
  lispEval :: String -> Maybe AST
  lispEval s = case filter ((== "") . snd) $ readP_to_S expr $ trimH s of
    [] -> Nothing
    xs -> Just $ eval $ fst $ last xs
  
  trimH (x : xs) | x `elem` ",\r\n\t " = trimH xs
                 | otherwise           = x : xs
  