content: module Lambdabot.Plugin.Haskell.Pl.Common (
          Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..),
          bt, sizeExpr, mapTopLevel, getExpr,
          operators, opchars, reservedOps, lookupOp, lookupFix, minPrec, maxPrec,
          comp, flip', id', const', scomb, cons, nil, fix', if',
          makeList, getList, readM,
          Assoc(..),
          module Data.Maybe,
          module Control.Arrow,
          module Data.List,
          module Control.Monad,
          module GHC.Base
      ) where
  
  import Data.Maybe (isJust, fromJust)
  import Data.List (intersperse, minimumBy)
  import qualified Data.Map as M
  
  import Control.Applicative
  import Control.Monad
  import Control.Arrow (first, second, (***), (&&&), (|||), (+++))
  
  import Text.ParserCombinators.Parsec.Expr (Assoc(..))
  
  import GHC.Base (assert)
  
  
  -- The rewrite rules can be found at the end of the file Rules.hs
  
  -- Not sure if passing the information if it was used as infix or prefix
  -- is worth threading through the whole thing is worth the effort,
  -- but it stays that way until the prettyprinting algorithm gets more
  -- sophisticated.
  data Fixity = Pref | Inf deriving Show
  
  instance Eq Fixity where
    _ == _ = True
  
  instance Ord Fixity where
    compare _ _ = EQ
  
  data Expr
    = Var Fixity String
    | Lambda Pattern Expr
    | App Expr Expr
    | Let [Decl] Expr
    deriving (Eq, Ord)
  
  data Pattern
    = PVar String
    | PCons Pattern Pattern
    | PTuple Pattern Pattern
    deriving (Eq, Ord)
  
  data Decl = Define {
    declName :: String,
    declExpr :: Expr
  } deriving (Eq, Ord)
  
  data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord)
  
  mapTopLevel :: (Expr -> Expr) -> TopLevel -> TopLevel
  mapTopLevel f tl = case getExpr tl of (e, c) -> c $ f e
  
  getExpr :: TopLevel -> (Expr, Expr -> TopLevel)
  getExpr (TLD True (Define foo e)) = (Let [Define foo e] (Var Pref foo),
                                       \e' -> TLD False $ Define foo e')
  getExpr (TLD False (Define foo e)) = (e, \e' -> TLD False $ Define foo e')
  getExpr (TLE e)      = (e, TLE)
  
  sizeExpr :: Expr -> Int
  sizeExpr (Var _ _) = 1
  sizeExpr (App e1 e2) = sizeExpr e1 + sizeExpr e2 + 1
  sizeExpr (Lambda _ e) = 1 + sizeExpr e
  sizeExpr (Let ds e) = 1 + sum (map sizeDecl ds) + sizeExpr e where
    sizeDecl (Define _ e') = 1 + sizeExpr e'
  
  comp, flip', id', const', scomb, cons, nil, fix', if' :: Expr
  comp   = Var Inf  "."
  flip'  = Var Pref "flip"
  id'    = Var Pref "id"
  const' = Var Pref "const"
  scomb  = Var Pref "ap"
  cons   = Var Inf  ":"
  nil    = Var Pref "[]"
  fix'   = Var Pref "fix"
  if'    = Var Pref "if'"
  
  makeList :: [Expr] -> Expr
  makeList = foldr (\e1 e2 -> cons `App` e1 `App` e2) nil
  
  -- Modularity is a drag
  getList :: Expr -> ([Expr], Expr)
  getList (c `App` x `App` tl) | c == cons = first (x:) $ getList tl
  getList e = ([],e)
  
  bt :: a
  bt = undefined
  
  shift, minPrec, maxPrec :: Int
  shift = 0
  maxPrec = shift + 10
  minPrec = 0
  
  -- operator precedences are needed both for parsing and prettyprinting
  operators :: [[(String, (Assoc, Int))]]
  operators = (map . map . second . second $ (+shift))
    [[inf "." AssocRight 9, inf "!!" AssocLeft 9],
     [inf name AssocRight 8 | name <- ["^", "^^", "**"]],
     [inf name AssocLeft 7
       | name <- ["*", "/", "`quot`", "`rem`", "`div`", "`mod`", ":%", "%"]],
     [inf name AssocLeft 6  | name <- ["+", "-"]],
     [inf name AssocRight 5 | name <- [":", "++", "<+>"]],
     [inf name AssocNone 4
       | name <- ["==", "/=", "<", "<=", ">=", ">", "`elem`", "`notElem`"]] ++[inf name AssocLeft 4 | name <- ["<*","*>","<$>","<$","<**>"]],
     [inf "&&" AssocRight 3, inf "***" AssocRight 3, inf "&&&" AssocRight 3, inf "<|>" AssocLeft 3],
     [inf "||" AssocRight 2, inf "+++" AssocRight 2, inf "|||" AssocRight 2],
     [inf ">>" AssocLeft 1, inf ">>=" AssocLeft 1, inf "=<<" AssocRight 1, inf ">>>" AssocRight 1, inf "^>>" AssocRight 1, inf "^<<" AssocRight 1],
     [inf name AssocRight 0 | name <- ["$", "$!", "`seq`"]]
    ] where
    inf name assoc fx = (name, (assoc, fx))
  
  opchars :: [Char]
  opchars = "!@#$%^*./|=-+:?<>&"
  
  reservedOps :: [String]
  reservedOps = ["->", "..", "="]
  
  opFM :: M.Map String (Assoc, Int)
  opFM = (M.fromList $ concat operators)
  
  lookupOp :: String -> Maybe (Assoc, Int)
  lookupOp k = M.lookup k opFM
  
  lookupFix :: String -> (Assoc, Int)
  lookupFix str = case lookupOp $ str of
    Nothing -> (AssocLeft, 9 + shift)
    Just x  -> x
  
  readM :: (Read a, Alternative m) => String -> m a
  readM str = case reads str of
     [(x, "")] -> pure x
     _         -> empty
  