{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LINE 1 "Quipper/Libraries/QuipperASCIIParser/Parse.hs" #-}
-- ----------------------------------------------------------------------
-- | This module contains the code for parsing the ASCII output from
-- Quipper, into a GatePlus.
-- This program is heavily based on, and heavily borrows from the QCLParser.

module Quipper.Libraries.QuipperASCIIParser.Parse where

import Quipper.Internal.Circuit
import Data.IntMap hiding (map)

import Text.ParserCombinators.ReadP
import Data.Char (isDigit)
import qualified Data.Map as Map

-- ----------------------------------------------------------------------
-- | A type for gates, plus other circuit output, empty lines, and subroutine defs.
data GatePlus = G Gate [(Wire,Wiretype)]
              | I [(Wire,Wiretype)]
              | O [(Wire,Wiretype)]
              | EmptyLine
              | CommentLine String
              | SubroutineName String
              | SubroutineShape String
              | Controllable ControllableFlag
 deriving Show

-- ----------------------------------------------------------------------
-- * Parsing

-- | Parse a string literal. 
string_literal :: ReadP String
string_literal = do
  char '"'
  s <- string_with_escaped_chars ""
  char '"'
  return s
 where
  string_with_escaped_chars :: String -> ReadP String
  string_with_escaped_chars input = do
   s <- munch (\x -> x /= '\\' && x /= '"')
   let s'  = input ++ s
   rest <- look
   case rest of
    '"' : _ -> return s'
    '\\' : _ -> do
      e <- escaped_char
      string_with_escaped_chars (s' ++ [e])
    _ -> do
      pfail

-- | Parse an escaped character, such as @\0@, @\n@, @\\@, etc.
escaped_char :: ReadP Char
escaped_char = do
  char '\\'
  c <- get
  return (Map.findWithDefault c c map)
  where
    -- The official escape codes. We allow any other escaped character
    -- to denote itself. We do not permit "\&" to denote the empty string.
    map = Map.fromList [
      ('0', '\0'),
      ('a', '\a'),
      ('b', '\b'),
      ('f', '\f'),
      ('n', '\n'),
      ('r', '\r'),
      ('t', '\t'),
      ('v', '\v'),
      ('"', '\"'),
      ('\'', '\''),
      ('\\', '\\')
      ]

-- | Parse a signless integer. We avoid the usual trick ('readS_to_P'
-- 'reads'), because this introduces backtracking errors.
int :: ReadP Int
int = do
  s <- munch1 isDigit
  return $ (read s :: Int)

-- | Parse a floating point number. We avoid the usual trick
-- ('readS_to_P' 'reads'), because this introduces backtracking
-- errors.
double :: ReadP Double
double = do
  (s, _) <- gather parse_double
  return $ (read s :: Double)
  where
    parse_double = do
      option '+' (char '+' +++ char '-')
      munch isDigit
      optional (char '.' >> munch1 isDigit)
      optional (char 'e' >> option '+' (char '+' +++ char '-') >> int)
      
-- | Parse a comma separated list.
commalist :: ReadP a -> ReadP [a]
commalist elt = sepBy elt (skipSpaces >> char ',' >> skipSpaces)

-- | Parse a control structure.
control :: ReadP (Signed Wire,Wiretype)
control = do
  val <- choice [char '+',char '-']
  skipSpaces
  w <- int
  c <- option 'q' (char 'c')
  let wt = case c of
            'c' -> Cbit
            _ -> Qbit
  return (Signed w (val == '+'),wt)

-- | Parse a list of controls.
controls :: ReadP ([Signed Wire],[(Wire,Wiretype)])
controls = do
  skipSpaces
  string "with controls=["
  cwts <- commalist control
  char ']'
  let cs = map fst cwts
  let wts = map (\(Signed w _,wt) -> (w,wt)) cwts
  return (cs,wts)

-- | Parse a 'Wiretype'.
wiretype :: ReadP Wiretype
wiretype = do
  c <- choice [string "Qbit",string "Cbit"]
  case c of
    "Qbit" -> return Qbit
    "Cbit" -> return Cbit
    _ -> error "The impossible has happened"

-- | Parse a wire and its type.
wire :: ReadP (Int,Wiretype)
wire = do
  skipSpaces
  w <- int
  char ':'
  t <- wiretype
  return (w,t)

-- | Parse a list of input/output wires and types.
wires :: ReadP [(Int,Wiretype)]
wires = do
  skipSpaces
  ws <- commalist wire
  return ws

-- | Parse the string \"none\", 
-- returning an empty list of input/output wires and types.
none :: ReadP [(Int,Wiretype)]
none = do
  skipSpaces
  string "none"
  return []

-- | Consume an optional \"*\". Return 'True' if consumed, and 'False'
-- otherwise.
inversechar :: ReadP Bool  
inversechar = do
  c <- option '+' (char '*')
  return (c == '*')

-- | Consume a label.
label' :: ReadP (Int,String)
label' = do
  w <- int
  char ':'
  lab <- string_literal
  return (w,lab)

-- | Consumer any character other than \')\', \']\', or \',\'.
labelchar :: ReadP String
labelchar = do
  c <- satisfy (\x -> not (x `elem` ")],"))
  return [c]

-- | Consume an index of the form [...].
labelbracket :: ReadP String
labelbracket = do
  char '['
  s <- munch (\x -> not (x `elem` "[]"))
  char ']'
  return ("[" ++ s ++ "]")

-- | Consume a list of labels.
labels :: ReadP [(Int,String)]
labels = do
    skipSpaces
    char '('
    ls <- commalist label'
    char ')'
    return ls

-- | Consume a 'BoxId' followed by a \']\' character.
{-
ascii_of_boxid (BoxId name shape) = show name ++ ", shape " ++ show shape
-}
box_id :: ReadP BoxId
box_id = do
   name <- string_literal
   skipSpaces
   char ','
   skipSpaces
   string "shape"
   skipSpaces
   shape <- string_literal
   return (BoxId name shape)

-- | Consume an optional 'NoControlFlag', returning 'False' if it isn't present.
nocontrolflag :: ReadP NoControlFlag
nocontrolflag = do
 skipSpaces
 ncf <- option "" (string "with nocontrol")
 return (ncf == "with nocontrol")

-- | Parse a single line of ASCII output into a 'Gate'. This function
-- needs to be kept in line with Quipper's
-- 'Quipper.Internal.Printing.ascii_render_gate' function.
ascii_line :: ReadP GatePlus
ascii_line = choice [
    do -- Inputs: w:Type, w:Type ...
    string "Inputs:"
    ws <- choice [wires,none]
    eof
    return (I ws),
    do -- Outputs: w:Type, w:Type ...
    string "Outputs:"
    ws <- choice [wires,none]
    eof
    return (O ws),
    do -- An empty line can be parsed as an EmptyLine
    skipSpaces
    eof
    return EmptyLine,
    do -- "A comment in a circuit is any line beginnning with a # character"
    -- The comment is stored for later use as a CommentLine
    skipSpaces
    char '#'
    skipSpaces
    comment <- manyTill (satisfy (\_ -> True)) eof
    eof
    return (CommentLine comment),
    do -- Subroutine: "name" (keeping unquoted version for backward comp.)
    string "Subroutine: "
    name <- string_literal +++ manyTill (satisfy (\_ -> True)) eof
    eof
    return (SubroutineName name),
    do -- Shape: "shape" (keeping unquoted version for backward comp.)
    string "Shape: "
    shape <- string_literal +++ manyTill (satisfy (\_ -> True)) eof
    eof
    return (SubroutineShape shape),
    do -- Controllable: yes/no/classically
    string "Controllable: "
    val_string <- choice [string "yes",string "no", string "classically"]
    let val = case val_string of
               "yes" -> AllCtl
               "no" -> NoCtl
               "classically" -> OnlyClassicalCtl
               _ -> error "The impossible happened"
    eof
    return (Controllable val),
{-
For backward compatibility:
ascii_render_gate (QNot w c ncf) = 
  "QNot(" ++ show w ++ ")" 
  ++ ascii_render_controls wtm c 
  ++ ascii_render_nocontrolflag ncf
-}
    do 
    string "QNot("
    w <- int
    char ')'
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    return (G (QGate "not" False [w] [] cs ncf) wts),
{-
For backward compatibility:
ascii_render_gate (QMultinot ws c ncf) = 
  "QMultinot(" ++ string_of_list "" ", " "" "" show ws ++ ")" 
  ++ ascii_render_controls wtm c 
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QMultinot("
    ws <- commalist int
    char ')'
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    return (G (QGate "multinot" False ws [] cs ncf) wts),    
{-
For backward compatibility:
ascii_render_gate (QHad w c ncf) = 
  "QHad(" ++ show w ++ ")" 
  ++ ascii_render_controls wtm c 
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QHad("
    w <- int
    char ')'
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    return (G (QGate "H" False [w] [] cs ncf) wts),
{-
For backward compatibility:
ascii_render_gate (QSwap w1 w2 c ncf) = 
  "QSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" 
  ++ ascii_render_controls wtm c 
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QSwap("
    w1 <- int
    char ','
    w2 <- int
    char ')'
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    return (G (QGate "swap" False [w1, w2] [] cs ncf) wts),
{-
For backward compatibility:
ascii_render_gate (QW w1 w2 c ncf) = 
  "QW(" ++ show w1 ++ "," ++ show w2 ++ ")" 
  ++ ascii_render_controls wtm c 
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QW("
    w1 <- int
    char ','
    w2 <- int
    char ')'
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    return (G (QGate "W" False [w1, w2] [] cs ncf) wts),
{-
ascii_render_gate (GPhase t ws c ncf) = 
  "GPhase() with t=" ++ show t 
  ++ ascii_render_controls wtm c 
  ++ ascii_render_nocontrolflag ncf
  ++ string_of_list " with anchors=[" ", " "]" "" show ws
-}
    do
    string "GPhase() with t="
    t <- double
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    ws <- option [] (do
      skipSpaces
      string "with anchors=["
      ws <- commalist int
      char ']'
      return ws )
    eof
    return (G (GPhase t ws cs ncf) wts),
{-
ascii_render_gate (QGate name inv ws1 ws2 c ncf) = 
  "QGate[" ++ show name ++ "]" 
  ++ optional inv "*" 
  ++ (string_of_list "(" "," ")" "()" show ws1)
  ++ (string_of_list "; [" "," "]" "" show ws2)
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QGate["
    name <- string_literal
    char ']'
    inv <- inversechar
    char '('
    ws1 <- commalist int
    char ')'
    ws2 <- option [] (do
      string "; ["
      ws <- commalist int
      char ']'
      return ws )
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    return (G (QGate name inv ws1 ws2 cs ncf) wts),   
{-
ascii_render_gate (QRot name inv theta ws1 ws2 c ncf) = 
  "QRot[" ++ show name ++ "," ++ (show theta) ++ "]" 
  ++ optional inv "*"
  ++ (string_of_list "(" "," ")" "()" show ws1)
  ++ (string_of_list "; [" "," "]" "" show ws2)
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QRot["
    name <- string_literal
    char ','
    theta <- double
    char ']'
    inv <- inversechar
    char '('
    ws1 <- commalist int
    char ')'
    ws2 <- option [] ( do
      string "; ["
      ws <- commalist int
      char ']'
      return ws )
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    return (G (QRot name inv theta ws1 ws2 cs ncf) wts),
{-
ascii_render_gate (CNot w c ncf) = 
  "CNot(" ++ show w ++ ")" 
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
-}
    do 
    string "CNot("
    w <- int
    char ')'
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    return (G (CNot w cs ncf) wts),
{-
ascii_render_gate (CGate n w c ncf) = 
  "CGate[" ++ show n ++ "]" ++ (string_of_list "(" "," ")" "()" show (w:c))
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "CGate["
    name <- string_literal
    string "]("
    ws <- commalist int
    char ')'
    ncf <- nocontrolflag
    eof
    return (G (CGate name (head ws) (tail ws) ncf) []),
{-
ascii_render_gate (CGateInv n w c ncf) = 
  "CGate[" ++ show n ++ "]" ++ "*" ++ (string_of_list "(" "," ")" "()" show (w:c))
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "CGate["
    name <- string_literal
    string "]*("
    ws <- commalist int
    char ')'
    ncf <- nocontrolflag
    eof
    return (G (CGateInv name (head ws) (tail ws) ncf) []),
{-
ascii_render_gate (CSwap w1 w2 c ncf) = 
  "CSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" 
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "CSwap("
    w1 <- int
    char ','
    w2 <- int
    char ')'
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    return (G (CSwap w1 w2 cs ncf) wts),
{-
ascii_render_gate (QPrep w ncf) = 
  "QPrep(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QPrep("
    w <- int
    char ')'
    ncf <- nocontrolflag
    eof
    return (G (QPrep w ncf) []),
{-
ascii_render_gate (QUnprep w ncf) = 
  "QUnprep(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QUnprep("
    w <- int
    char ')'
    ncf <- nocontrolflag
    eof
    return (G (QUnprep w ncf) []),
{-
ascii_render_gate (QInit b w ncf) = 
  "QInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QInit"
    val_char <- choice [char '0',char '1']
    let val = val_char == '1'
    char '('
    w <- int
    char ')'
    ncf <- nocontrolflag
    eof
    return (G (QInit val w ncf) []),
{-
ascii_render_gate (CInit b w ncf) = 
  "CInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "CInit"
    val_char <- choice [char '0',char '1']
    let val = val_char == '1'
    char '('
    w <- int
    char ')'
    ncf <- nocontrolflag
    eof
    return (G (CInit val w ncf) []),
{-
ascii_render_gate (QTerm b w ncf) = 
  "QTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "QTerm"
    val_char <- choice [char '0',char '1']
    let val = val_char == '1'
    char '('
    w <- int
    char ')'
    ncf <- nocontrolflag
    eof
    return (G (QTerm val w ncf) []),
{-
ascii_render_gate (CTerm b w ncf) = 
  "CTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
-}
    do
    string "CTerm"
    val_char <- choice [char '0',char '1']
    let val = val_char == '1'
    char '('
    w <- int
    char ')'
    ncf <- nocontrolflag
    eof
    return (G (CTerm val w ncf) []),
{-
ascii_render_gate (QMeas w) = 
  "QMeas(" ++ show w ++ ")"
-}
    do
    string "QMeas("
    w <- int
    char ')'
    eof
    return (G (QMeas w) []),
{-
ascii_render_gate (QDiscard w) = 
  "QDiscard(" ++ show w ++ ")"
-}
    do
    string "QDiscard("
    w <- int
    char ')'
    eof
    return (G (QDiscard w) []),
{-
ascii_render_gate (CDiscard w) = 
  "CDiscard(" ++ show w ++ ")"
-}
    do
    string "CDiscard("
    w <- int
    char ')'
    eof
    return (G (CDiscard w) []),
{-
ascii_render_gate (DTerm b w) = 
  "DTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
-}
    do
    string "DTerm"
    vc <- char '0' +++ char '1'
    let b = case vc of
             '0' -> False
             '1' -> True
             _ -> error "The impossible has happend" 
    char '('
    w <- int
    char ')'
    eof
    return (G (DTerm b w) []),
{-
ascii_render_gate (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf) = 
  "Subroutine" ++ show_rep ++ "[" ++ show (string_of_boxid boxid) ++ "]"
  ++ optional inv "*"
  ++ " "
  ++ (string_of_list "(" "," ")" "()" show ws1)
  ++ (string_of_list " -> (" "," ")" "()" show ws2)
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
  where
    show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")"
-}
-- The parser returns a subroutine with dummy arities, and controllable flag,
-- and repeat flag, as
-- this information is not in a subroutine line in the ASCII output. 
-- The information is added when the GatePlus is evaluated, as the first phase of
-- parsing will have collected the information. 
    do
    string "Subroutine"
    reps <- option 1 $ do
     string "(x"
     r <- int
     char ')'
     return (toInteger r)
    char '['
    boxid <- box_id
    char ']'
    inv <- inversechar
    string " ("
    ws1 <- commalist int
    string ") -> ("
    ws2 <- commalist int
    char ')'
    (cs,wts) <- option ([],[]) controls
    ncf <- nocontrolflag
    eof
    let dummy = error "attempted evaluation of a dummy value"
    return (G (Subroutine boxid inv ws1 dummy ws2 dummy cs ncf dummy (RepeatFlag reps)) wts),   
{-
ascii_render_gate (Comment s inv ws) = 
  "Comment[" ++ show s ++ "]" 
  ++ optional inv "*"
  ++ (string_of_list "(" ", " ")" "()" (\(w,s) -> show w ++ ":" ++ show s) ws)
-}
    do
    string "Comment"
    skipSpaces
    char '['
    comment <- string_literal
    char ']'
    inv <- inversechar
    ls <- labels
    eof
    return (G (Comment comment inv ls) [])
  ]

-- | The overall parsing function, reading a line of ASCII output, and
-- producing a 'GatePlus'.
parse_ascii_line :: String -> Maybe GatePlus
parse_ascii_line s =
  case readP_to_S ascii_line s of
    (h, _):_ -> Just h
    _ -> Nothing
  where
    readline = do
      skipSpaces
      l <- ascii_line
      skipSpaces
      eof
      return l