module Kempe.File ( tcFile
                  , dumpMono
                  , dumpTyped
                  , irFile
                  , x86File
                  , dumpX86
                  , compile
                  , parsedFp
                  ) where

-- common b/w test suite and exec, repl utils
import           Control.Composition       ((.*))
import           Control.Exception         (Exception, throwIO)
import           Data.Bifunctor            (bimap)
import qualified Data.ByteString.Lazy      as BSL
import qualified Data.Set                  as S
import           Kempe.AST
import           Kempe.Asm.X86.Type
import           Kempe.Error
import           Kempe.IR
import           Kempe.Lexer
import           Kempe.Parser
import           Kempe.Pipeline
import           Kempe.Proc.Nasm
import           Kempe.Shuttle
import           Kempe.TyAssign
import           Prettyprinter             (Doc, hardline)
import           Prettyprinter.Render.Text (putDoc)

tcFile :: FilePath -> IO (Either (Error ()) ())
tcFile :: FilePath -> IO (Either (Error ()) ())
tcFile FilePath
fp = do
    ByteString
contents <- FilePath -> IO ByteString
BSL.readFile FilePath
fp
    (Int
maxU, Module AlexPosn AlexPosn AlexPosn
m) <- Either
  (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
-> IO (Int, Module AlexPosn AlexPosn AlexPosn)
forall e a. Exception e => Either e a -> IO a
yeetIO (Either
   (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
 -> IO (Int, Module AlexPosn AlexPosn AlexPosn))
-> Either
     (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
-> IO (Int, Module AlexPosn AlexPosn AlexPosn)
forall a b. (a -> b) -> a -> b
$ ByteString
-> Either
     (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
parseWithMax ByteString
contents
    Either (Error ()) () -> IO (Either (Error ()) ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Error ()) () -> IO (Either (Error ()) ()))
-> Either (Error ()) () -> IO (Either (Error ()) ())
forall a b. (a -> b) -> a -> b
$ ((), Int) -> ()
forall a b. (a, b) -> a
fst (((), Int) -> ())
-> Either (Error ()) ((), Int) -> Either (Error ()) ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TypeM () () -> Either (Error ()) ((), Int)
forall a x. Int -> TypeM a x -> Either (Error a) (x, Int)
runTypeM Int
maxU (Module AlexPosn AlexPosn AlexPosn -> TypeM () ()
forall a c b. Module a c b -> TypeM () ()
checkModule Module AlexPosn AlexPosn AlexPosn
m)

yeetIO :: Exception e => Either e a -> IO a
yeetIO :: Either e a -> IO a
yeetIO = (e -> IO a) -> (a -> IO a) -> Either e a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

dumpTyped :: FilePath -> IO ()
dumpTyped :: FilePath -> IO ()
dumpTyped FilePath
fp = do
    (Int
i, Module AlexPosn AlexPosn AlexPosn
m) <- FilePath -> IO (Int, Module AlexPosn AlexPosn AlexPosn)
parsedFp FilePath
fp
    (Module () (StackType ()) (StackType ())
mTyped, Int
_) <- Either (Error ()) (Module () (StackType ()) (StackType ()), Int)
-> IO (Module () (StackType ()) (StackType ()), Int)
forall e a. Exception e => Either e a -> IO a
yeetIO (Either (Error ()) (Module () (StackType ()) (StackType ()), Int)
 -> IO (Module () (StackType ()) (StackType ()), Int))
-> Either (Error ()) (Module () (StackType ()) (StackType ()), Int)
-> IO (Module () (StackType ()) (StackType ()), Int)
forall a b. (a -> b) -> a -> b
$ Int
-> TypeM () (Module () (StackType ()) (StackType ()))
-> Either (Error ()) (Module () (StackType ()) (StackType ()), Int)
forall a x. Int -> TypeM a x -> Either (Error a) (x, Int)
runTypeM Int
i (Module AlexPosn AlexPosn AlexPosn
-> TypeM () (Module () (StackType ()) (StackType ()))
forall a c b.
Module a c b -> TypeM () (Module () (StackType ()) (StackType ()))
assignModule Module AlexPosn AlexPosn AlexPosn
m)
    Doc Any -> IO ()
forall ann. Doc ann -> IO ()
putDoc (Doc Any -> IO ()) -> Doc Any -> IO ()
forall a b. (a -> b) -> a -> b
$ Module () (StackType ()) (StackType ()) -> Doc Any
forall ann. Module () (StackType ()) (StackType ()) -> Doc ann
prettyTypedModule Module () (StackType ()) (StackType ())
mTyped

dumpMono :: FilePath -> IO ()
dumpMono :: FilePath -> IO ()
dumpMono FilePath
fp = do
    (Int
i, Module AlexPosn AlexPosn AlexPosn
m) <- FilePath -> IO (Int, Module AlexPosn AlexPosn AlexPosn)
parsedFp FilePath
fp
    Module () (ConsAnn MonoStackType) MonoStackType
mMono <- Either (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType)
-> IO (Module () (ConsAnn MonoStackType) MonoStackType)
forall e a. Exception e => Either e a -> IO a
yeetIO (Either
   (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType)
 -> IO (Module () (ConsAnn MonoStackType) MonoStackType))
-> Either
     (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType)
-> IO (Module () (ConsAnn MonoStackType) MonoStackType)
forall a b. (a -> b) -> a -> b
$ Int
-> Module AlexPosn AlexPosn AlexPosn
-> Either
     (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType)
forall a c b.
Int
-> Module a c b
-> Either
     (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType)
monomorphize Int
i Module AlexPosn AlexPosn AlexPosn
m
    Doc Any -> IO ()
forall ann. Doc ann -> IO ()
putDoc (Doc Any -> IO ()) -> Doc Any -> IO ()
forall a b. (a -> b) -> a -> b
$ Module () (StackType ()) (StackType ()) -> Doc Any
forall ann. Module () (StackType ()) (StackType ()) -> Doc ann
prettyTypedModule ((KempeDecl () (ConsAnn MonoStackType) MonoStackType
 -> KempeDecl () (StackType ()) (StackType ()))
-> Module () (ConsAnn MonoStackType) MonoStackType
-> Module () (StackType ()) (StackType ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ConsAnn MonoStackType -> StackType ())
-> (MonoStackType -> StackType ())
-> KempeDecl () (ConsAnn MonoStackType) MonoStackType
-> KempeDecl () (StackType ()) (StackType ())
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ConsAnn MonoStackType -> StackType ()
forall b. ConsAnn ([KempeTy b], [KempeTy b]) -> StackType b
fromMonoConsAnn MonoStackType -> StackType ()
forall b. ([KempeTy b], [KempeTy b]) -> StackType b
fromMono) Module () (ConsAnn MonoStackType) MonoStackType
mMono)
    where fromMono :: ([KempeTy b], [KempeTy b]) -> StackType b
fromMono ([KempeTy b]
is, [KempeTy b]
os) = Set (Name b) -> [KempeTy b] -> [KempeTy b] -> StackType b
forall b. Set (Name b) -> [KempeTy b] -> [KempeTy b] -> StackType b
StackType Set (Name b)
forall a. Set a
S.empty [KempeTy b]
is [KempeTy b]
os
          fromMonoConsAnn :: ConsAnn ([KempeTy b], [KempeTy b]) -> StackType b
fromMonoConsAnn (ConsAnn Int64
_ Word8
_ ([KempeTy b], [KempeTy b])
ty) = ([KempeTy b], [KempeTy b]) -> StackType b
forall b. ([KempeTy b], [KempeTy b]) -> StackType b
fromMono ([KempeTy b], [KempeTy b])
ty

dumpIR :: Int -> Module a c b -> Doc ann
dumpIR :: Int -> Module a c b -> Doc ann
dumpIR = [Stmt] -> Doc ann
forall ann. [Stmt] -> Doc ann
prettyIR ([Stmt] -> Doc ann)
-> (([Stmt], WriteSt) -> [Stmt]) -> ([Stmt], WriteSt) -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Stmt], WriteSt) -> [Stmt]
forall a b. (a, b) -> a
fst (([Stmt], WriteSt) -> Doc ann)
-> (Int -> Module a c b -> ([Stmt], WriteSt))
-> Int
-> Module a c b
-> Doc ann
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* Int -> Module a c b -> ([Stmt], WriteSt)
forall a c b. Int -> Module a c b -> ([Stmt], WriteSt)
irGen

dumpX86 :: Int -> Module a c b -> Doc ann
dumpX86 :: Int -> Module a c b -> Doc ann
dumpX86 = [X86 X86Reg ()] -> Doc ann
forall reg a ann. Pretty reg => [X86 reg a] -> Doc ann
prettyAsm ([X86 X86Reg ()] -> Doc ann)
-> (Int -> Module a c b -> [X86 X86Reg ()])
-> Int
-> Module a c b
-> Doc ann
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* Int -> Module a c b -> [X86 X86Reg ()]
forall a c b. Int -> Module a c b -> [X86 X86Reg ()]
x86Alloc

irFile :: FilePath -> IO ()
irFile :: FilePath -> IO ()
irFile FilePath
fp = do
    (Int, Module AlexPosn AlexPosn AlexPosn)
res <- FilePath -> IO (Int, Module AlexPosn AlexPosn AlexPosn)
parsedFp FilePath
fp
    Doc Any -> IO ()
forall ann. Doc ann -> IO ()
putDoc (Doc Any -> IO ()) -> Doc Any -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Module AlexPosn AlexPosn AlexPosn -> Doc Any)
-> (Int, Module AlexPosn AlexPosn AlexPosn) -> Doc Any
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Module AlexPosn AlexPosn AlexPosn -> Doc Any
forall a c b ann. Int -> Module a c b -> Doc ann
dumpIR (Int, Module AlexPosn AlexPosn AlexPosn)
res Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
forall ann. Doc ann
hardline

parsedFp :: FilePath -> IO (Int, Module AlexPosn AlexPosn AlexPosn)
parsedFp :: FilePath -> IO (Int, Module AlexPosn AlexPosn AlexPosn)
parsedFp FilePath
fp = do
    ByteString
contents <- FilePath -> IO ByteString
BSL.readFile FilePath
fp
    Either
  (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
-> IO (Int, Module AlexPosn AlexPosn AlexPosn)
forall e a. Exception e => Either e a -> IO a
yeetIO (Either
   (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
 -> IO (Int, Module AlexPosn AlexPosn AlexPosn))
-> Either
     (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
-> IO (Int, Module AlexPosn AlexPosn AlexPosn)
forall a b. (a -> b) -> a -> b
$ ByteString
-> Either
     (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
parseWithMax ByteString
contents

x86File :: FilePath -> IO ()
x86File :: FilePath -> IO ()
x86File FilePath
fp = do
    (Int, Module AlexPosn AlexPosn AlexPosn)
res <- FilePath -> IO (Int, Module AlexPosn AlexPosn AlexPosn)
parsedFp FilePath
fp
    Doc Any -> IO ()
forall ann. Doc ann -> IO ()
putDoc (Doc Any -> IO ()) -> Doc Any -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Module AlexPosn AlexPosn AlexPosn -> Doc Any)
-> (Int, Module AlexPosn AlexPosn AlexPosn) -> Doc Any
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Module AlexPosn AlexPosn AlexPosn -> Doc Any
forall a c b ann. Int -> Module a c b -> Doc ann
dumpX86 (Int, Module AlexPosn AlexPosn AlexPosn)
res Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
forall ann. Doc ann
hardline

compile :: FilePath
        -> FilePath
        -> Bool -- ^ Debug symbols?
        -> IO ()
compile :: FilePath -> FilePath -> Bool -> IO ()
compile FilePath
fp FilePath
o Bool
dbg = do
    ByteString
contents <- FilePath -> IO ByteString
BSL.readFile FilePath
fp
    (Int, Module AlexPosn AlexPosn AlexPosn)
res <- Either
  (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
-> IO (Int, Module AlexPosn AlexPosn AlexPosn)
forall e a. Exception e => Either e a -> IO a
yeetIO (Either
   (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
 -> IO (Int, Module AlexPosn AlexPosn AlexPosn))
-> Either
     (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
-> IO (Int, Module AlexPosn AlexPosn AlexPosn)
forall a b. (a -> b) -> a -> b
$ ByteString
-> Either
     (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)
parseWithMax ByteString
contents
    Doc Any -> FilePath -> Bool -> IO ()
forall ann. Doc ann -> FilePath -> Bool -> IO ()
writeO ((Int -> Module AlexPosn AlexPosn AlexPosn -> Doc Any)
-> (Int, Module AlexPosn AlexPosn AlexPosn) -> Doc Any
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Module AlexPosn AlexPosn AlexPosn -> Doc Any
forall a c b ann. Int -> Module a c b -> Doc ann
dumpX86 (Int, Module AlexPosn AlexPosn AlexPosn)
res) FilePath
o Bool
dbg