content: {-# LANGUAGE DeriveDataTypeable #-}
  {-# OPTIONS_GHC -fno-cse #-}
  
  module Main where
  
  import Data.Char (isUpper, toLower)
  import Obj
  import Options.Applicative hiding ((<|>))
  import Path
  import Reify
  import Text.Parsec ((<|>))
  import qualified Text.Parsec as Parsec
  import Types
  import Util
  
  data Args = Args
    { prefixToRemove :: String,
      kebabCase :: Bool,
      emitCName :: Bool,
      sourcePath :: String
    }
    deriving (Show)
  
  parseArgs :: Parser Args
  parseArgs =
    Args
      <$> strOption (long "prefixtoremove" <> short 'p' <> metavar "ITEM" <> value "")
      <*> switch (long "kebabcase" <> short 'f')
      <*> switch (long "emitcname" <> short 'c')
      <*> argument str (metavar "FILE")
  
  main = do
    parsedArgs <- execParser $ Options.Applicative.info (parseArgs <**> helper) fullDesc
    let path = sourcePath parsedArgs
    if path /= ""
      then do
        source <- slurp path
        putStrLn
          ( joinWith
              "\n"
              ( map
                  pretty
                  ( parseHeaderFile
                      path
                      source
                      (prefixToRemove parsedArgs)
                      (kebabCase parsedArgs)
                      (emitCName parsedArgs)
                  )
              )
          )
      else print parsedArgs
  
  parseHeaderFile :: FilePath -> String -> String -> Bool -> Bool -> [XObj]
  parseHeaderFile path src prefix kebab cName =
    case Parsec.runParser cSyntax () path src of
      Left err -> error (show err)
      Right ok -> concat ok
    where
      cSyntax :: Parsec.Parsec String () [[XObj]]
      cSyntax = Parsec.sepBy line (Parsec.char '\n')
      line :: Parsec.Parsec String () [XObj]
      line =
        Parsec.try prefixedFunctionPrototype
          <|> Parsec.try functionPrototype
          <|> Parsec.try define
          <|> discarded
      define :: Parsec.Parsec String () [XObj]
      define = do
        Parsec.many spaceOrTab
        Parsec.string "#define"
        Parsec.many spaceOrTab
        name <- Parsec.many1 identifierChar
        argList <- Parsec.optionMaybe argList
        Parsec.many spaceOrTab
        _ <- defineBody
        Parsec.many spaceOrTab
        -- OBS! Never kebab
        case argList of
          Nothing ->
            let tyXObj =
                  XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
             in pure (createRegisterForm name tyXObj prefix False cName)
          Just args ->
            let argsTy = genTypes (length args)
                tyXObj = toFnTypeXObj argsTy ("a", 0)
             in pure (createRegisterForm name tyXObj prefix False cName)
        where
          argList = do
            _ <- Parsec.char '('
            args <-
              Parsec.sepBy
                ( Parsec.many spaceOrTab
                    >> Parsec.many1 identifierChar
                )
                (Parsec.char ',')
            _ <- Parsec.char ')'
            pure args
          genTypes 0 = []
          genTypes n = (("a" ++ show n), 0) : genTypes (n - 1)
      defineBody :: Parsec.Parsec String () ()
      defineBody = do
        s <- Parsec.many (Parsec.noneOf "\\\n")
        ending <- Parsec.optionMaybe (Parsec.string "\\\n")
        case ending of
          Nothing ->
            do
              c <- Parsec.optionMaybe (Parsec.noneOf "\n")
              case c of
                Just _ -> defineBody
                Nothing -> pure ()
          Just _ -> defineBody
      prefixedFunctionPrototype :: Parsec.Parsec String () [XObj]
      prefixedFunctionPrototype = do
        Parsec.many spaceOrTab
        _ <- Parsec.many1 identifierChar
        functionPrototype
      functionPrototype :: Parsec.Parsec String () [XObj]
      functionPrototype = do
        Parsec.many spaceOrTab
        returnTypeString <- Parsec.many1 identifierChar
        stars1 <- stars
        Parsec.many1 spaceOrTab
        stars2 <- stars
        name <- Parsec.many1 identifierChar
        Parsec.many spaceOrTab
        argTypeStrings <-
          Parsec.try voidArg
            <|> argList
        Parsec.many spaceOrTab
        Parsec.char ';'
        Parsec.many (Parsec.noneOf "\n")
        let tyXObj = toFnTypeXObj argTypeStrings (returnTypeString, length stars1 + length stars2)
        pure (createRegisterForm name tyXObj prefix kebab cName)
      voidArg :: Parsec.Parsec String () [(String, Int)]
      voidArg = do
        _ <- Parsec.string "(void)"
        pure []
      argList :: Parsec.Parsec String () [(String, Int)]
      argList = do
        Parsec.char '('
        args <- Parsec.sepBy arg (Parsec.char ',')
        Parsec.char ')'
        pure args
      arg :: Parsec.Parsec String () (String, Int)
      arg = do
        Parsec.many spaceOrTab
        _ <- Parsec.option "" $ do
          Parsec.string "const"
          Parsec.many spaceOrTab
        argTypeAsString <- Parsec.many1 identifierChar
        stars1 <- stars
        Parsec.many1 spaceOrTab
        stars2 <- stars
        _ <- Parsec.many1 identifierChar
        Parsec.many spaceOrTab
        pure (argTypeAsString, length stars1 + length stars2)
      stars :: Parsec.Parsec String () String
      stars = Parsec.many (Parsec.char '*')
      spaceOrTab :: Parsec.Parsec String () Char
      spaceOrTab = Parsec.choice [Parsec.char ' ', Parsec.char '\t']
      discarded :: Parsec.Parsec String () [XObj]
      discarded = do
        discardedLine <- Parsec.many (Parsec.noneOf "\n")
        pure []
  
  --pure [(XObj (Str ("DISCARDED: " ++ discardedLine)) Nothing Nothing)]
  
  createRegisterForm :: String -> XObj -> String -> Bool -> Bool -> [XObj]
  createRegisterForm name tyXObj prefix kebab cName =
    let carpName =
          (if kebab then (toKebab . lowerFirst) else id)
            (if prefix == "" then name else removePrefix prefix name)
        emitName = name
     in [ XObj
            ( Lst
                ( [ (XObj (Sym (SymPath [] "register") Symbol) Nothing Nothing),
                    (XObj (Sym (SymPath [] carpName) Symbol) Nothing Nothing),
                    tyXObj
                  ]
                    ++ if (prefix /= "") || kebab || cName
                      then [(XObj (Str emitName) Nothing Nothing)]
                      else []
                )
            )
            Nothing
            Nothing
        ]
  
  toFnTypeXObj :: [(String, Int)] -> (String, Int) -> XObj
  toFnTypeXObj argTypeStrings returnTypeString =
    ( XObj
        ( Lst
            [ (XObj (Sym (SymPath [] "λ") Symbol) Nothing Nothing),
              (XObj (Arr (map (reify . cTypeToCarpType) argTypeStrings)) Nothing Nothing),
              (XObj (Sym (SymPath [] (show (cTypeToCarpType returnTypeString))) Symbol) Nothing Nothing)
            ]
        )
        Nothing
        Nothing
    )
  
  toTypeXObj :: (String, Int) -> XObj
  toTypeXObj typeString =
    (XObj (Sym (SymPath [] (show (cTypeToCarpType typeString))) Symbol) Nothing Nothing)
  
  cTypeToCarpType :: (String, Int) -> Ty
  cTypeToCarpType ("char", 0) = CCharTy
  cTypeToCarpType ("int", 0) = IntTy
  cTypeToCarpType ("bool", 0) = BoolTy
  cTypeToCarpType ("long", 0) = LongTy
  cTypeToCarpType ("double", 0) = DoubleTy
  cTypeToCarpType ("float", 0) = FloatTy
  cTypeToCarpType ("void", 0) = UnitTy
  cTypeToCarpType (s, 0) = (StructTy (ConcreteNameTy (SymPath [] s)) [])
  cTypeToCarpType (x, stars) = (PointerTy (cTypeToCarpType (x, stars - 1)))
  
  identifierChar :: Parsec.Parsec String () Char
  identifierChar = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.char '_']
  
  removePrefix :: String -> String -> String
  removePrefix prefix s =
    case Parsec.runParser match () "" s of
      Left err -> s
      Right ok -> ok
    where
      match =
        do
          _ <- Parsec.string prefix
          Parsec.many1 identifierChar
  
  lowerFirst :: String -> String
  lowerFirst (c : cs) = toLower c : cs
  
  toKebab :: String -> String
  toKebab [] = []
  toKebab (c : cs) = (if isUpper c then ['-', toLower c] else [c]) ++ toKebab cs
  