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

-- common b/w test suite and exec, repl utils
import           Control.Composition       ((.*))
import           Control.Exception         (Exception, throwIO)
import           Data.Bifunctor            (bimap)
import           Data.Functor              (void)
import           Data.Semigroup            ((<>))
import qualified Data.Set                  as S
import           Data.Tuple.Extra          (fst3)
import           Data.Typeable             (Typeable)
import           Kempe.AST
import           Kempe.Asm.X86.Type
import           Kempe.Check.Pattern
import           Kempe.Check.TopLevel
import           Kempe.Error
import           Kempe.IR
import           Kempe.Lexer
import           Kempe.Module
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
    (Int
maxU, Declarations AlexPosn AlexPosn AlexPosn
m) <- FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn)
parseProcess FilePath
fp
    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
$ do
        Either (Error ()) ((), Int) -> Either (Error ()) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either (Error ()) ((), Int) -> Either (Error ()) ())
-> Either (Error ()) ((), Int) -> Either (Error ()) ()
forall a b. (a -> b) -> a -> b
$ Int -> TypeM () () -> Either (Error ()) ((), Int)
forall a x. Int -> TypeM a x -> Either (Error a) (x, Int)
runTypeM Int
maxU (Declarations AlexPosn AlexPosn AlexPosn -> TypeM () ()
forall a c b. Declarations a c b -> TypeM () ()
checkModule Declarations AlexPosn AlexPosn AlexPosn
m)
        Maybe (Error ()) -> Either (Error ()) ()
mErr (Maybe (Error ()) -> Either (Error ()) ())
-> Maybe (Error ()) -> Either (Error ()) ()
forall a b. (a -> b) -> a -> b
$ Declarations AlexPosn AlexPosn () -> Maybe (Error ())
forall a c b. Declarations a c b -> Maybe (Error b)
checkModuleExhaustive (KempeDecl AlexPosn AlexPosn AlexPosn
-> KempeDecl AlexPosn AlexPosn ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KempeDecl AlexPosn AlexPosn AlexPosn
 -> KempeDecl AlexPosn AlexPosn ())
-> Declarations AlexPosn AlexPosn AlexPosn
-> Declarations AlexPosn AlexPosn ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Declarations AlexPosn AlexPosn AlexPosn
m)

warnFile :: FilePath -> IO (Maybe (Warning AlexPosn))
warnFile :: FilePath -> IO (Maybe (Warning AlexPosn))
warnFile FilePath
fp = do
    (Int
_, Declarations AlexPosn AlexPosn AlexPosn
m) <- FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn)
parseProcess FilePath
fp
    Maybe (Warning AlexPosn) -> IO (Maybe (Warning AlexPosn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Warning AlexPosn) -> IO (Maybe (Warning AlexPosn)))
-> Maybe (Warning AlexPosn) -> IO (Maybe (Warning AlexPosn))
forall a b. (a -> b) -> a -> b
$ Declarations AlexPosn AlexPosn AlexPosn -> Maybe (Warning AlexPosn)
forall a c. Declarations a c a -> Maybe (Warning a)
topLevelCheck Declarations 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, Declarations AlexPosn AlexPosn AlexPosn
m) <- FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn)
parseProcess FilePath
fp
    (Declarations () (StackType ()) (StackType ())
mTyped, Int
_) <- Either
  (Error ()) (Declarations () (StackType ()) (StackType ()), Int)
-> IO (Declarations () (StackType ()) (StackType ()), Int)
forall e a. Exception e => Either e a -> IO a
yeetIO (Either
   (Error ()) (Declarations () (StackType ()) (StackType ()), Int)
 -> IO (Declarations () (StackType ()) (StackType ()), Int))
-> Either
     (Error ()) (Declarations () (StackType ()) (StackType ()), Int)
-> IO (Declarations () (StackType ()) (StackType ()), Int)
forall a b. (a -> b) -> a -> b
$ Int
-> TypeM () (Declarations () (StackType ()) (StackType ()))
-> Either
     (Error ()) (Declarations () (StackType ()) (StackType ()), Int)
forall a x. Int -> TypeM a x -> Either (Error a) (x, Int)
runTypeM Int
i (Declarations AlexPosn AlexPosn AlexPosn
-> TypeM () (Declarations () (StackType ()) (StackType ()))
forall a c b.
Declarations a c b
-> TypeM () (Declarations () (StackType ()) (StackType ()))
assignModule Declarations 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
$ Declarations () (StackType ()) (StackType ()) -> Doc Any
forall ann.
Declarations () (StackType ()) (StackType ()) -> Doc ann
prettyTypedModule Declarations () (StackType ()) (StackType ())
mTyped

dumpMono :: FilePath -> IO ()
dumpMono :: FilePath -> IO ()
dumpMono FilePath
fp = do
    (Int
i, Declarations AlexPosn AlexPosn AlexPosn
m) <- FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn)
parseProcess FilePath
fp
    (Declarations () (ConsAnn MonoStackType) MonoStackType
mMono, SizeEnv
_) <- Either
  (Error ())
  (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
-> IO
     (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
forall e a. Exception e => Either e a -> IO a
yeetIO (Either
   (Error ())
   (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
 -> IO
      (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv))
-> Either
     (Error ())
     (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
-> IO
     (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
forall a b. (a -> b) -> a -> b
$ Int
-> Declarations AlexPosn AlexPosn AlexPosn
-> Either
     (Error ())
     (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
forall a c b.
Int
-> Declarations a c b
-> Either
     (Error ())
     (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
monomorphize Int
i Declarations 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
$ Declarations () (StackType ()) (StackType ()) -> Doc Any
forall ann.
Declarations () (StackType ()) (StackType ()) -> Doc ann
prettyTypedModule ((KempeDecl () (ConsAnn MonoStackType) MonoStackType
 -> KempeDecl () (StackType ()) (StackType ()))
-> Declarations () (ConsAnn MonoStackType) MonoStackType
-> Declarations () (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) Declarations () (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 :: Typeable a => Int -> Declarations a c b -> Doc ann
dumpIR :: Int -> Declarations 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 -> Declarations a c b -> ([Stmt], WriteSt, SizeEnv))
-> Int
-> Declarations a c b
-> Doc ann
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* Int -> Declarations a c b -> ([Stmt], WriteSt, SizeEnv)
forall a c b.
Typeable a =>
Int -> Declarations a c b -> ([Stmt], WriteSt, SizeEnv)
irGen

dumpX86 :: Typeable a => Int -> Declarations a c b -> Doc ann
dumpX86 :: Int -> Declarations 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 -> Declarations a c b -> [X86 X86Reg ()])
-> Int
-> Declarations a c b
-> Doc ann
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* Int -> Declarations a c b -> [X86 X86Reg ()]
forall a c b.
Typeable a =>
Int -> Declarations a c b -> [X86 X86Reg ()]
x86Alloc

irFile :: FilePath -> IO ()
irFile :: FilePath -> IO ()
irFile FilePath
fp = do
    (Int, Declarations AlexPosn AlexPosn AlexPosn)
res <- FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn)
parseProcess 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 -> Declarations AlexPosn AlexPosn AlexPosn -> Doc Any)
-> (Int, Declarations AlexPosn AlexPosn AlexPosn) -> Doc Any
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Declarations AlexPosn AlexPosn AlexPosn -> Doc Any
forall a c b ann.
Typeable a =>
Int -> Declarations a c b -> Doc ann
dumpIR (Int, Declarations AlexPosn AlexPosn AlexPosn)
res Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
forall ann. Doc ann
hardline

x86File :: FilePath -> IO ()
x86File :: FilePath -> IO ()
x86File FilePath
fp = do
    (Int, Declarations AlexPosn AlexPosn AlexPosn)
res <- FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn)
parseProcess 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 -> Declarations AlexPosn AlexPosn AlexPosn -> Doc Any)
-> (Int, Declarations AlexPosn AlexPosn AlexPosn) -> Doc Any
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Declarations AlexPosn AlexPosn AlexPosn -> Doc Any
forall a c b ann.
Typeable a =>
Int -> Declarations a c b -> Doc ann
dumpX86 (Int, Declarations 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
    (Int, Declarations AlexPosn AlexPosn AlexPosn)
res <- FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn)
parseProcess FilePath
fp
    Doc Any -> FilePath -> Bool -> IO ()
forall ann. Doc ann -> FilePath -> Bool -> IO ()
writeO ((Int -> Declarations AlexPosn AlexPosn AlexPosn -> Doc Any)
-> (Int, Declarations AlexPosn AlexPosn AlexPosn) -> Doc Any
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Declarations AlexPosn AlexPosn AlexPosn -> Doc Any
forall a c b ann.
Typeable a =>
Int -> Declarations a c b -> Doc ann
dumpX86 (Int, Declarations AlexPosn AlexPosn AlexPosn)
res) FilePath
o Bool
dbg