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           Data.Tuple.Extra          (fst3)
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, SizeEnv
_) <- Either
  (Error ())
  (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
-> IO (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
forall e a. Exception e => Either e a -> IO a
yeetIO (Either
   (Error ())
   (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
 -> IO (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv))
-> Either
     (Error ())
     (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
-> IO (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
forall a b. (a -> b) -> a -> b
$ Int
-> Module AlexPosn AlexPosn AlexPosn
-> Either
     (Error ())
     (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
forall a c b.
Int
-> Module a c b
-> Either
     (Error ())
     (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
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, SizeEnv) -> [Stmt])
-> ([Stmt], WriteSt, SizeEnv)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Stmt], WriteSt, SizeEnv) -> [Stmt]
forall a b c. (a, b, c) -> a
fst3 (([Stmt], WriteSt, SizeEnv) -> Doc ann)
-> (Int -> Module a c b -> ([Stmt], WriteSt, SizeEnv))
-> 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, SizeEnv)
forall a c b. Int -> Module a c b -> ([Stmt], WriteSt, SizeEnv)
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