ct2hs.hs

module Main where
import Prelude hiding (lines)
import Botworld hiding (limit, Error(..), memory, contents)
import Control.Arrow
import Control.Applicative
import Control.Monad
import Data.Char
import Data.List (elemIndex)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import System.Environment
import System.Exit (exitSuccess, exitFailure)
import System.IO (hPutStrLn, stderr)
import Text.Parsec hiding ((<|>), many, spaces)
import Text.Parsec.String (Parser)
import Text.Printf (printf)

type Name = String
type Size = Maybe Int
type Declaration = (Name, Size, Value)
data Value = Code [INSTRUCTION] | Data Constree deriving Show

-- These are the instructions recognized in ct files.
-- COPY, EXEC, and WRITE require that you have a register named NIL.
-- If you want the instructions to act like they sound, NIL should always
-- contain exactly Nil.
data INSTRUCTION
  = NILIFY    Name
  | CONS      Name Name Name
  | DEST      Name Name Name
  | COPY      Name Name
  | CONDCOPY  Name Name Name
  | EXEC      Name
  | CONDEXEC  Name Name
  | PUSH      Name Name
  | POP       Name Name
  | WRITE     Name
  | CONDWRITE Name Name
  deriving Show

data Error = NoSuchRegister Name | DuplicateDeclaration Name deriving Show
type File = [Declaration]

names :: File -> [Name]
names f = [n | (n, _, _) <- f]

validate :: [Declaration] -> Either Error File
validate decls = case safeSet $ names decls of
  Left dup -> Left $ DuplicateDeclaration dup
  Right _ -> Right decls

safeSet :: Ord k => [k] -> Either k (Set k)
safeSet = foldM safeInsert Set.empty where
  safeInsert s x = if Set.member x s then Left x else Right $ Set.insert x s

convert :: File -> Either Error [Register]
convert f = mapM compile f where
  compile (_, s, Code l) = (make s . encode) <$> mapM instruct l
  compile (_, s, Data t) = Right $ make s t
  make Nothing t = R (size t) t
  make (Just s) t = R s (trim s t)
  instruct (NILIFY tgt)           = Nilify      <$> r tgt
  instruct (CONS fnt bck tgt)     = Construct   <$> r fnt   <*> r bck <*> r tgt
  instruct (DEST src fnt bck)     = Deconstruct <$> r src   <*> r fnt <*> r bck
  instruct (COPY src dst)         = CopyIfNil   <$> r "NIL" <*> r src <*> r dst
  instruct (CONDCOPY tst src dst) = CopyIfNil   <$> r tst   <*> r src <*> r dst
  instruct (EXEC prg)             = CopyIfNil   <$> r "NIL" <*> r prg <*> return 0
  instruct (CONDEXEC tst prg)     = CopyIfNil   <$> r tst   <*> r prg <*> return 0
  instruct (PUSH src stk)         = Construct   <$> r src   <*> r stk <*> r stk
  instruct (POP stk tgt)          = Deconstruct <$> r stk   <*> r tgt <*> r stk
  instruct (WRITE src)            = CopyIfNil   <$> r "NIL" <*> r src <*> return 2
  instruct (CONDWRITE tst src)    = CopyIfNil   <$> r tst   <*> r src <*> return 2
  r x = maybe (Left $ NoSuchRegister x) Right (elemIndex x $ names f)

file :: Parser [Declaration]
file = many declaration

spaces :: Parser ()
spaces = void $ many $ satisfy isSpace

spaces1 :: Parser ()
spaces1 = void $ many1 $ satisfy isSpace

declaration :: Parser Declaration
declaration = (,,) <$> h <*> s <*> v where
    h = bullshit *> name
    s = spaces *> limit <* spaces <* char ':' <* spaces <* bullshit
    v = try (Data <$> (tdata <* bullshit)) <|> (Code <$> many (instruction <* bullshit)) <?> "a value"

bullshit :: Parser ()
bullshit = void $ many ignored where
    ignored = try spaces1 <|> try comment <?> "ignored text"

comment :: Parser ()
comment = char ';' *> skipMany (noneOf "\r\n")

limit :: Parser Size
limit = optionMaybe (read <$> many1 digit)

name :: Parser Name
name = (:) <$> satisfy isAlpha_ <*> many (satisfy isAlphaNum_) where
  isAlpha_ = (||) <$> isAlpha <*> (== '_')
  isAlphaNum_ = (||) <$> isAlphaNum <*> (== '_')

instruction :: Parser INSTRUCTION
instruction
  =   try (string "CONS"      *> (CONS      <$> ref <*> ref <*> ref))
  <|> try (string "DEST"      *> (DEST      <$> ref <*> ref <*> ref))
  <|> try (string "COPY"      *> (COPY      <$> ref <*> ref))
  <|> try (string "CONDCOPY"  *> (CONDCOPY  <$> ref <*> ref <*> ref))
  <|> try (string "EXEC"      *> (EXEC      <$> ref))
  <|> try (string "CONDEXEC"  *> (CONDEXEC  <$> ref <*> ref))
  <|> try (string "PUSH"      *> (PUSH      <$> ref <*> ref))
  <|> try (string "POP"       *> (POP       <$> ref <*> ref))
  <|> try (string "WRITE"     *> (WRITE     <$> ref))
  <|> try (string "CONDWRITE" *> (CONDWRITE <$> ref <*> ref))
  <?> "an instruction"
  where ref = spaces *> name <* spaces

encreg :: Parser Register
encreg = R <$> (string "R" *> spaces1 *> int <* spaces1) <*> tdata

memory :: Parser Memory
memory = listOf encreg

int :: Parser Int
int = read <$> many1 digit

direction :: Parser Direction
direction
  =   try (string "N" *> pure N)
  <|> try (string "NE" *> pure NE)
  <|> try (string "E" *> pure E)
  <|> try (string "SE" *> pure SE)
  <|> try (string "S" *> pure S)
  <|> try (string "SW" *> pure SW)
  <|> try (string "W" *> pure W)
  <|> try (string "NW" *> pure NW)
  <?> "a direction"

command :: Parser Command
command
  =   try (Move    <$> (string "Move" *> spaces1 *> direction))
  <|> try (Lift    <$> (string "Lift" *> spaces1 *> int))
  <|> try (Drop    <$> (string "Drop" *> spaces1 *> int))
  <|> try (Inspect <$> (string "Inspect" *> spaces1 *> int))
  <|> try (Destroy <$> (string "Destroy" *> spaces1 *> int))
  <|> try (Build   <$> (string "Build" *> spaces1 *> listOf int <* spaces1) <*> memory)
  <|> try (string "Pass" *> pure Pass)
  <?> "a command"

instr :: Parser Instruction
instr
  =   try (Nilify <$> (string "Nilify" *> spaces1 *> int))
  <|> try (Construct <$> (string "Construct" *> spaces1 *> int <* spaces1) <*> (int <* spaces1) <*> int)
  <|> try (Deconstruct <$> (string "Deconstruct" *> spaces1 *> int <* spaces1) <*> (int <* spaces1) <*> int)
  <|> try (CopyIfNil <$> (string "CopyIfNil" *> spaces1 *> int <* spaces1) <*> (int <* spaces1) <*> int)
  <?> "a literal instruction"

constree :: Parser Constree
constree
  =   try (string "Nil" *> pure Nil)
  <|> try (Cons <$> (string "Cons" *> spaces1 *> constree <* spaces1) <*> constree)
  <?> "some constree"

listOf :: Parser a -> Parser [a]
listOf p = bracketed (sepBy p (spaces *> char ',' <* spaces)) where
  bracketed = between (char '[' *> spaces) (spaces <* char ']')

treeTuple :: Parser Constree
treeTuple = treeify <$> bracketed (sepBy1 tdata (spaces *> char ',' <* spaces)) where
  bracketed = between (char '(' *> spaces) (spaces <* char ')')
  treeify [] = error "sepBy1 failure"
  treeify [x] = x
  treeify (x:xs) = Cons x (treeify xs)

tdata :: Parser Constree
tdata
  = try (encode <$> int)
  <|> try (encode <$> command)
  <|> try (encode <$> instr)
  <|> try constree
  <|> try treeTuple
  <|> try (encode <$> listOf tdata)
  <?> "valid data"

load :: String -> String -> Either String File
load fname txt = do
  decls <- left show $ parse file fname txt
  left show $ validate decls

main :: IO ()
main = do
  args <- getArgs
  when (null args) $ do
    hPutStrLn stderr "Not enough arguments. (Try ct2hs --help.)"
    exitFailure
  let basename = head args
  when (basename == "-h" || basename == "--help") $ do
    putStrLn "ct2hs NAME [MODULE]"
    putStrLn ""
    putStrLn "NAME should specify a .ct file WITHOUT the .ct extension."
    putStrLn "MODULE determines the haskell module name; it defaults to NAME."
    putStrLn "Output will be written to stdout; redirect it as neccessary."
    putStrLn ""
    putStrLn "example:"
    putStrLn " > ct2hs Omega Precommit.Omega > Omega.hs"
    exitSuccess
  when (length args > 2) $ do
    hPutStrLn stderr "Too many arguments. (Try ct2hs --help.)"
    exitFailure
  let modname = if length args > 1 then args !! 1 else basename
  let filename = basename <> ".ct"
  contents <- readFile filename
  case load filename contents of
    Left e -> putStrLn e
    Right f -> either print (printModule modname $ names f) (convert f)

template :: String
template = unlines
  [ "module %s (machine, registerNames, inspect, view) where"
  , "import Botworld"
  , "import Botworld.Debug"
  , ""
  , "machine :: Memory"
  , "machine = %s"
  , ""
  , "registerNames :: [String]"
  , "registerNames = %s"
  , ""
  , "inspect :: Memory -> [String]"
  , "inspect = inspectMemory registerNames"
  , ""
  , "view :: Robot -> IO ()"
  , "view = putStrLn . unlines . inspect . memory"
  ]

moduleFor :: String -> [String] -> Memory -> String
moduleFor modname rs m = printf template modname (show m) (show rs)

printModule :: String -> [String] -> Memory -> IO ()
printModule modname rnames m = putStr (moduleFor modname rnames m)