recursion without schemes.hs

-- stack --resolver=lts-13.8 script

{-# OPTIONS -Wall -Wno-orphans #-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

import           Data.EDN    (Tagged (..), TaggedValue, Value (..), renderText)
import           Data.EDN.QQ (edn)
import           Data.Text   (Text)
import qualified Data.Text   as Text

tvToList :: TaggedValue -> [TaggedValue]
tvToList tv = case tv of
    NoTag      v -> go v
    Tagged _ _ v -> go v
  where
    go :: Value -> [TaggedValue]
    go v = case v of
        List     vs -> vs
        _           -> error (show v)

main :: IO ()
main =
    either (fail . Text.unpack) print $ calc [edn|
        (+
            (/ 6 3 2)
            (* 2 3)
            (- 4 5))
    |]

paraOf :: (a -> [a]) -> (a -> [b] -> b) -> a -> b
paraOf thisToList f = go where go a = f a $ map go $ thisToList a

calc :: TaggedValue -> Either Text Double
calc = paraOf tvToList go where
    go (NoTag v) children = case v of
        Floating f -> pure f
        Integer  i -> pure $ fromIntegral i
        List (NoTag (Symbol "" op) : _)   -> do
            checked <- sequence $ drop 1 children
            case op of
                "+" -> Right (foldr (+) 0.0 checked)
                "-" -> Right (foldr (-) 0.0 checked)
                "*" -> Right (foldr (*) 1.0 checked)
                "/" -> case checked of
                    -- From the clojure docs:
                    -- If no denominators are supplied, returns 1/numerator,
                    -- else returns numerator divided by all of the denominators.
                    []       -> Left "No arguments given to `/`"
                    [n]      -> Right (1 / n)
                    (n : ds) -> Right (foldl (/) n ds)
                _ -> Left $ "Unknown operation: " <> op
        _          -> Left $ "unknown " <> renderText (NoTag v)
    go Tagged{} _ = Left "tagged not supported"