content: {-# 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
  