HaskellEmacs.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}

-- WARNING: Please note that this file is autogenerated.
--
-- If you want to change this file, you have to clone the github repo and apply the changes in a local repo.

module Main where
{--<<import>>--}
import           Control.Applicative              (optional, (<|>))
import           Control.Arrow                    hiding (app)
import           Control.Concurrent
import           Control.Monad                    (forever, (<=<))
import           Control.Monad.Trans.Reader
import           Control.Parallel.Strategies
import           Data.AttoLisp
import qualified Data.Attoparsec.ByteString.Char8 as AC
import qualified Data.Attoparsec.ByteString.Lazy  as A
import qualified Data.ByteString.Lazy.Char8       as B hiding (length)
import qualified Data.ByteString.Lazy.UTF8        as B (length)
import qualified Data.Map                         as M
import           Data.Maybe
import           Data.Text                        (Text)
import qualified Data.Text                        as T
import           Foreign.Emacs.Internal
import           Language.Haskell.Exts            hiding (List, String, Symbol,
                                                   name, sym)
import qualified Language.Haskell.Exts.Syntax     as S (Name (Ident, Symbol))
import           System.IO                        (hFlush, stdout)
import           Data.Typeable

-- https://gist.github.com/nushio3/5867066
arity :: Typeable a => a -> Int
arity x = go $ typeOf x
  where
    go tr
      | isFun $ typeRepTyCon tr = 1 + go (last $ snd $ splitTyConApp tr)
      | otherwise               = 0

    funTyCon = typeRepTyCon $ typeRep (Proxy @(Int -> Int))
    isFun = (funTyCon ==)

data Instruction = EmacsToHaskell Lisp
                 | HaskellToEmacs B.ByteString
                 | StartDialog (Emacs Lisp) Int

{-@ StartDialog :: Emacs Lisp -> Nat -> Instruction @-}

-- | Watch for commands and dispatch them in a seperate fork.
main :: IO ()
main = do
  printer <- newChan
  getter  <- newEmptyMVar
  lock    <- newMVar ()
  _       <- forkIO . forever $ readChan printer >>= B.putStr >> hFlush stdout
  is      <- fullParse <$> B.getContents
  mapM_ (forkIO . runInstruction lock getter printer) is

runInstruction :: MVar () -> MVar Lisp -> Chan B.ByteString -> Instruction -> IO ()
runInstruction _ g _ (EmacsToHaskell ls)                 = putMVar g   $! ls
runInstruction _ _ p (HaskellToEmacs msg)                = writeChan p $! msg
runInstruction l g p (StartDialog (EmacsInternal rdr) n) = withMVar l $ \_ -> do
  x <- runReaderT rdr (g, p)
  writeChan p . formatResult n $ Success x

-- | Recursively evaluate a lisp in parallel, using functions defined
-- by the user (see documentation of the emacs function `haskell-emacs-init').
{-@ Lazy traverseLisp @-}
traverseLisp :: Either (Emacs Lisp) Lisp -> Result (Either (Emacs Lisp) Lisp)
traverseLisp l = case l of
  Right (List (Symbol x:xs)) -> sym (T.filter (/='\\') x) xs
  Right (List xs)            -> Right . List <$> evl xs
  Right (Symbol "nil")       -> Success $ Right nil
  _                          -> Success l
  where {-@ assume evl :: xs:[Lisp] -> Result {v:[Lisp] | len xs == len v} @-}
        evl      = noNest <=< (sequence . parMap rdeepseq (traverseLisp . Right))
        sym x xs = maybe (Right . List . (Symbol x:) <$> evl xs)
                         (=<< (if length xs == 1 then head else List) <$> evl xs)
                         $ M.lookup x dispatcher
        noNest   = either (const (Error "Emacs monad isn't nestable."))
                          Success . sequence

-- | Takes a stream of instructions and returns lazy list of
-- results.
{-@ Lazy fullParse @-}
fullParse :: B.ByteString -> [Instruction]
fullParse a = case parseInput a of A.Done a' b -> b : fullParse a'
                                   A.Fail {}   -> []

-- | Parse an instruction and stamp the number of the instruction into
-- the result.
parseInput :: B.ByteString -> A.Result Instruction
parseInput = A.parse $ do
  i          <- A.option 0 AC.decimal
  isInternal <- isJust <$> optional "|"
  l          <- lisp
  return $ if isInternal
    then EmacsToHaskell l
    else case traverseLisp $ Right l of
      Success (Left x)  -> StartDialog x i
      Success (Right x) -> HaskellToEmacs . formatResult i $ Success x
      Error x           -> HaskellToEmacs . formatResult i $ Error x

-- | Scrape the documentation of haskell functions to serve it in emacs.
{-@ getDocumentation :: x:[Text] -> Text -> {v:[Text] | len x == len v} @-}
getDocumentation :: [Text] -> Text -> [Text]
getDocumentation funs code =
  map ( \f -> T.unlines . (++) (filter (T.isPrefixOf (f <> " ::")) ls ++ [""])
      . reverse
      . map (T.dropWhile (`elem` ("- |" :: String)))
      . takeWhile (T.isPrefixOf "-- ")
      . reverse
      $ takeWhile (not . T.isPrefixOf (f <> " ")) ls
      ) funs
  where ls = T.lines code

{-@ formatResult :: Nat -> Result Lisp -> B.ByteString @-}
formatResult :: Int -> Result Lisp -> B.ByteString
formatResult i l = f $ case l of
      Success s -> (Just $ num i, encode s)
      Error s   -> (Nothing     , errorE s)
  where f (procNum, t) = encList (num (B.length t):maybeToList procNum) <> t
        errorE msg     = encList [Symbol "error", String $ T.pack msg]
        encList        = encode . List
        num            = Number . fromIntegral

-- | Map of available functions which get transformed to work on lisp.
dispatcher :: M.Map Text (Lisp -> Result (Either (Emacs Lisp) Lisp))
dispatcher = M.fromList $
  [ ("arityFormat", transform arityFormat . normalize)
  , ("allExports",  transform allExports)
  , ("arityList",   transform $ \() -> toDispatcher arityList)
  , ("formatCode",  transform $ uncurry formatCode)
  , ("getDocumentation", transform $ uncurry getDocumentation)
  ] ++ []{--<<export>>--}

-- | Transform a curried function to a function which receives and
-- returns lisp forms.
transform :: (FromLisp a, ToEmacs b) => (a -> b) -> Lisp -> Result (Either (Emacs Lisp) Lisp)
transform = (. fromLisp) . fmap . (toEmacs .)

-- | Prevent bad input for the bootstrap.
normalize :: Lisp -> Lisp
normalize l@(List _)      = l
normalize l@(DotList _ _) = l
normalize a               = List [a]

-- | Takes tuples of function names and their arities and returns
-- haskell source code which gets spliced back into a module.
toDispatcher :: [(String, Int)] -> (String, [String])
toDispatcher = ("++"++) . prettyPrint . listE . map fun
               &&& map (filter (\x -> x/=',' && x/='\n')
               . prettyPrint . pvarTuple . genNames "x" . snd)
  where fun (f,n) = tuple [strE f, app (function "transform")
                          $ lamE
                              [pvarTuple $ genNames "x" n]
                              (appFun (function f) . map var $ genNames "x" n)]

-- | List of functions and their arities (filled by emacs).
arityList :: [(String, Int)]
arityList = []{--<<arity>>--}

-- | Splice user functions into the haskell module.
formatCode :: (Text, Text, Text) -> Text -> Text
formatCode (imports, exports, arities) = inject "arity"  arities
                                       . inject "export" exports
                                       . inject "import" imports
  where inject s = T.replace ("{--<<" <> s <> ">>--}")

-- | Import statement of all modules and all their qualified functions.
allExports :: [String] -> Either String (String, [String])
allExports =
  (qualify . filter ((&&) <$> hasFunctions <*> isLibrary) <$>) .
  mapM exportsGet .
  filter (not . T.null . T.strip . T.pack)
  where
    qualify ys   = (unlines [prettyPrint $ ImportDecl
                                           noLoc
                                           (coerceMdlNameLoc q)
                                           True
                                           False
                                           False
                                           Nothing
                                           Nothing
                                           Nothing | (q,_) <- ys]
                       , [prettyPrint $ qvar (coerceMdlNameUnit q) (coerceNameUnit n) | (q,ns) <- ys, n <- ns])
    isLibrary    = (\(ModuleName _ nm) -> nm /= "Main") . fst
    hasFunctions = not . null . snd
    coerceMdlNameLoc (ModuleName _ nm) = ModuleName noLoc nm
    coerceMdlNameUnit (ModuleName _ nm) = ModuleName () nm
    coerceNameUnit (S.Ident  _ nm) = S.Ident  () nm
    coerceNameUnit (S.Symbol _ nm) = S.Symbol () nm

-- | List of haskell functions which get querried for their arity.
arityFormat :: [String] -> String
arityFormat = ("++"++) . prettyPrint
              . listE . map (\x -> tuple [strE x, app (function "arity")
                                                      (function x)])

-- | Retrieve the name and a list of exported functions of a haskell module.
-- It should use 'parseFileContents' to take pragmas into account.
exportsGet :: String -> Either String (ModuleName SrcSpanInfo, [Name SrcSpanInfo])
exportsGet content =
  case parseSrc of
    ParseOk mdl ->
      case mdl of
        (Module _ mMdlHead _ _ decls) ->
          case mMdlHead of
            Nothing -> Left $ "Error parsing module for: " <> content
            Just mdlHead -> Right
              (moduleHeadToModuleName mdlHead,
               fromJust (extractExportsFromHeader mdlHead <|> Just (exportsFromDecls decls)))
        XmlPage _ mdlName _ _ _ _ _ ->
          Left $ "TODO: Error parsing exports for XmlPage: " <> moduleNameToString mdlName
        XmlHybrid _ mdlHead _ _ _ _ _ _ _ ->
          Left $ "TODO: Error parsing exports for XmlHybrid: " <> show (moduleHeadToString <$> mdlHead)
    ParseFailed _ msg -> Left msg
  where
    parseSrc = parseFileContentsWithMode
                     defaultParseMode {fixities = Nothing}
                     content
    extractExportsFromHeader (ModuleHead _ _ _ mexps) =
      case mexps of
        Nothing -> Nothing
        Just (ExportSpecList _ exps) -> Just $ exportsFromHeader exps
    moduleNameToString (ModuleName _ str) = str
    moduleHeadToModuleName (ModuleHead _ mname _ _) = mname
    moduleHeadToString = moduleNameToString . moduleHeadToModuleName

exportsFromDecls :: [Decl l] -> [Name l]
exportsFromDecls = mapMaybe declarationNames

declarationNames :: Decl l -> Maybe (Name l)
declarationNames (FunBind _ ms) =
  case ms of
    (Match _ name _ _ _ : _)        -> Just name
    (InfixMatch _ _ name _ _ _ : _) -> Just name
    _                               -> Nothing
declarationNames (PatBind _ (PVar _ name) _ _) = Just name
declarationNames _                             = Nothing

-- | Extract the unqualified function names from an ExportSpec.
exportsFromHeader :: [ExportSpec l] -> [Name l]
exportsFromHeader = mapMaybe exportFunction

exportFunction :: ExportSpec l -> Maybe (Name l)
exportFunction (EVar _ qname) = unQualifiedName qname
exportFunction _              = Nothing

unQualifiedName :: QName l -> Maybe (Name l)
unQualifiedName (Qual _ _ name) = Just name
unQualifiedName (UnQual _ name) = Just name
unQualifiedName _               = Nothing