{-# LANGUAGE OverloadedLists #-}

module MiniC.Test where

import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Text (Text)
import System.IO.Unsafe (unsafePerformIO)

import Momo.Ident (Ident(..))
import Momo.Path qualified as Path
import Momo.ModTyping (typeModule)
import Momo.ModSyntax (ModTerm, ModType)
import Momo.ModSyntax qualified as Mod

import MiniC.Core qualified as MiniC

testType :: IO (ModType MiniC.Term)
testType = typeModule mempty testProg

testProg :: ModTerm MiniC.Term
testProg = Mod.Structure
  [ moduleIntOrder
  , moduleLexicographicOrder
  , moduleIntPairOrder
  ]

moduleIntOrder :: Mod.Definition MiniC.Term
moduleIntOrder =
  Mod.ModuleStr (ident_ "IntOrder") $
    Mod.Structure
      [ Mod.TypeStr (ident_ "T") () $
          MiniC.CInt
      , equalFun
      , lessFun
      ]
  where
    equalFun =
      Mod.ValueStr (ident_ "equal") $
        MiniC.FunDef
          [ (ident_ "x", MiniC.CInt)
          , (ident_ "y", MiniC.CInt)
          ]
          MiniC.CInt
          ( MiniC.Return $
              MiniC.BinaryOp
                "=="
                (MiniC.Variable $ Path.Ident $ ident_ "x")
                (MiniC.Variable $ Path.Ident $ ident_ "y")
          )

    lessFun =
      Mod.ValueStr (ident_ "less") $
        MiniC.FunDef
          [ (ident_ "x", MiniC.CInt)
          , (ident_ "y", MiniC.CInt)
          ]
          MiniC.CInt
          ( MiniC.Return $
              MiniC.BinaryOp
                "<"
                (MiniC.Variable $ Path.Ident $ ident_ "x")
                (MiniC.Variable $ Path.Ident $ ident_ "y")
          )

moduleLexicographicOrder :: Mod.Definition MiniC.Term
moduleLexicographicOrder =
  Mod.ModuleStr (ident_ "LexicographicOrder") $
    Mod.Functor (ident_ "Ord1") ordSig $
      Mod.Functor (ident_ "Ord2") ordSig $
        Mod.Structure
          [ equalFun
          , lessFun
          ]
  where
    ordSig = Mod.Signature
      [ Mod.TypeSig (ident_ "T") Mod.TypeDecl
          { kind     = ()
          , manifest = Nothing
          }

      , Mod.ValueSig (ident_ "equal") $
          MiniC.CFunction
            [ typename ["T"]
            , typename ["T"]
            ]
            MiniC.CInt

      , Mod.ValueSig (ident_ "less") $
          MiniC.CFunction
            [ typename ["T"]
            , typename ["T"]
            ]
            MiniC.CInt
      ]

    equalFun =
      Mod.ValueStr (ident_ "equal") $
        MiniC.FunDef
          [ (ident_ "p1", typename ["Ord1", "T"])
          , (ident_ "p2", typename ["Ord2", "T"])
          , (ident_ "q1", typename ["Ord1", "T"])
          , (ident_ "q2", typename ["Ord2", "T"])
          ]
          MiniC.CInt
          ( MiniC.If
              ( MiniC.Apply
                  (variable ["Ord1", "equal"])
                  [ variable ["p1"]
                  , variable ["q1"]
                  ]
              )
              ( MiniC.Return $
                  MiniC.Apply
                    (variable ["Ord2", "equal"])
                    [ variable ["p2"]
                    , variable ["q2"]
                    ]
              )
              ( MiniC.Return $
                  MiniC.IntConst 0
              )
          )

    lessFun =
      Mod.ValueStr (ident_ "less") $
        MiniC.FunDef
          [ (ident_ "p1", typename ["Ord1", "T"])
          , (ident_ "p2", typename ["Ord2", "T"])
          , (ident_ "q1", typename ["Ord1", "T"])
          , (ident_ "q2", typename ["Ord2", "T"])
          ]
          MiniC.CInt
          ( MiniC.Block []
              [ MiniC.If
                  ( MiniC.Apply
                      (variable ["Ord1", "less"])
                      [ variable ["p1"]
                      , variable ["q1"]
                      ]
                  )
                  ( MiniC.Return $
                      MiniC.IntConst 1
                  )
                  (MiniC.Block [] [])

              ,  MiniC.If
                  ( MiniC.UnaryOp "!" $
                      MiniC.Apply
                        (variable ["Ord1", "equal"])
                        [ variable ["p1"]
                        , variable ["q1"]
                        ]
                  )
                  ( MiniC.Return $
                      MiniC.IntConst 0
                  )
                  (MiniC.Block [] [])

              , MiniC.Return $
                  MiniC.Apply
                    (variable ["Ord2", "less"])
                    [ variable ["p2"]
                    , variable ["q2"]
                    ]
              ]
          )

moduleIntPairOrder :: Mod.Definition MiniC.Term
moduleIntPairOrder =
  Mod.ModuleStr (ident_ "IntPairOrder") $
    Mod.LongIdent (path_ ["LexicographicOrder"])
    `Mod.Apply`
    Mod.LongIdent (path_ ["IntOrder"])
    `Mod.Apply`
    Mod.LongIdent (path_ ["IntOrder"])

-- * Hacks

typename :: NonEmpty Text -> MiniC.CType
typename = MiniC.CTypename . path_

variable :: NonEmpty Text -> MiniC.Expr
variable = MiniC.Variable . path_

path_ :: NonEmpty Text -> Path.Path
path_ (root :| inner) =
  foldr
    (\field path -> Path.Dot{..})
    (Path.Ident $ ident_ root)
    inner

{-# NOINLINE ident_ #-}
ident_ :: Text -> Ident
ident_ name = unsafePerformIO do
  stamp <- atomicModifyIORef' identStampRef \x -> (x + 1, x)
  pure Ident{..}

{-# NOINLINE identStampRef #-}
identStampRef :: IORef Integer
identStampRef = unsafePerformIO (newIORef 0)