Condense token stream to application tree using operator fixities. TODO: remove crappiness.

TokenSoup.hs

{-# language ScopedTypeVariables, GADTs #-}

import Data.Ord  (comparing)
import Data.List
import Data.List.Utils

import Control.Arrow
import Control.Monad
import Control.Monad.Except

data OpTree t
  = Atom [t]
  | Post (OpTree t) t
  | Binary (OpTree t) t (OpTree t)

instance Show t => Show (OpTree t) where
    show tree = case tree of
        Atom     ts  -> br $ map show ts
        Post   l t   -> br [show l, show t]
        Binary l t r -> br [show l, show t, show r]
      where
        br = concat . (["("] ++) . (++[")"])

data Fixity
  = InfixLeft
  | InfixRight
  | Postfix
  | Prefix
    deriving (Eq, Show)

data OpDef = OpDef
  { fixity   :: Fixity
  , priority :: Int
  }
    deriving (Eq)

instance Show OpDef where
    show (OpDef InfixLeft  p) = "(_"  ++ show p ++ ")_"
    show (OpDef InfixRight p) = "_("  ++ show p ++ "_)"
    show (OpDef Postfix    p) = "_"   ++ show p
    show (OpDef Prefix     p) = "pre"

instance Ord OpDef where
    compare (OpDef Prefix p1) (OpDef Prefix p2) = EQ
    compare (OpDef Prefix _)  (OpDef _      _)  = GT
    compare (OpDef _      _)  (OpDef Prefix _)  = LT

    compare (OpDef Postfix p1) (OpDef Postfix p2) = compare p1 p2
    compare (OpDef Postfix _)  (OpDef _       _)  = GT
    compare (OpDef _       _)  (OpDef Postfix _)  = LT

    compare (OpDef InfixLeft p1) (OpDef InfixRight p2)
      | p1 == p2  = LT
      | otherwise = compare p1 p2

    compare (OpDef InfixRight p1) (OpDef InfixLeft p2)
      | p1 == p2  = GT
      | otherwise = compare p1 p2

    compare (OpDef _ p1) (OpDef _ p2) = compare p1 p2

prefix     = OpDef Prefix 1000
postfix    = OpDef Postfix
infixLeft  = OpDef InfixLeft
infixRight = OpDef InfixRight

data OpResolutionError t
    = NoLeftSide t
    | NoRightSide t
    deriving (Show)

resolve :: (t ~ String) => (t -> OpDef) -> [t] -> Either (OpResolutionError t) (OpTree t)
resolve op = fix $ \recure soup -> do
    let priorities = map (priority . op) soup
    let end = last priorities
    case fixity $ op $ last soup of
      Postfix | end == minimum priorities -> do
        when (null (init soup)) $ do
            throwError (NoLeftSide (last soup))

        sub <- recure (init soup)
        return $ (Post sub (last soup))

      _ | Prefix <- fixity $ op (minimumBy (comparing op) soup) -> do
        return (Atom soup)

      _ -> do
        let (x, pairs @ ((top, _) : _)) = splitByMax (comparing op) soup
        case fixity (op top) of
          InfixLeft -> do
            pairs <- forM pairs $ \(op, sub) -> do
                when (null sub) $ do
                    throwError (NoRightSide op)

                sub <- recure sub
                return (op, sub)

            when (null x) $ do
                throwError (NoLeftSide (head soup))
            x <- recure x
            return (foldl (uncurry . Binary) x pairs)

          InfixRight -> do
            (x, pairs) <- do
                let (ops, subs) = unzip pairs
                let y = last subs
                return (y, zip ops (init subs ++ [x]))

            pairs <- forM pairs $ \(op, sub) -> do
                when (null sub) $ do
                    throwError (NoRightSide op)

                sub <- recure sub
                return (op, sub)

            when (null x) $ do
                throwError (NoLeftSide (head soup))
            x <- recure x
            return (foldl (uncurry . binary) x pairs)

          Postfix ->
            throwError (NoLeftSide top)
  where
    binary l op r = Binary r op l

splitByMax :: (a0 -> a0 -> Ordering) -> [a0] -> ([a0], [(a0, [a0])])
splitByMax comparison list =
    splitBy equality list
  where
    equality = (EQ ==) . comparison maximal
    maximal  = minimumBy comparison list

splitBy predicate list =
    (first, go [] rest)
  where
    (first, rest) = predicate `break` list

    go acc [] = reverse acc
    go acc (max : rest) =
      let
        (next, others) = predicate `break` rest
      in
        go ((max, next) : acc) others

breakages list = map (\x -> (x, [x] `split` list)) list

break' pred [] = Nothing
break' pred ls = Just (break pred ls)

annotate :: (a -> b) -> [a] -> [(a, b)]
annotate = map . (id &&&)

op = maybe (OpDef Prefix 1000) id . (`lookup`
    [ "+" ==> infixLeft 50
    , "-" ==> infixLeft 50
    , "*" ==> infixLeft 90
    , "!" ==> postfix 70
    ])

test = resolve op
(==>) = (,)

text = words "a - b - c + d - f - g + e - r - t"