{-# OPTIONS_GHC -fglasgow-exts #-}

module Pugs.Frontend.P5AST where
import Pugs.AST
import Pugs.Run
import Data.Typeable

infixl 4 <~~
infixl 4 <<<

data P5AST
    = P5AST [P5AST]
    | Bare String
    | Items [P5AST]
    | OpNextState [P5AST]
    | OpScope [P5AST]
    | OpPrint [P5AST]
    | OpConst [P5AST]
    | OpCondExpr [P5AST]
    | OpLeave [P5AST]
    | OpNextstate [P5AST]
    | OpSassign [P5AST]
    | OpSeq [P5AST]
    | OpSne [P5AST]
    | OpStringify [P5AST]
    deriving (Show, Eq, Read, Typeable)

p5pil :: P5AST -> Exp
p5pil (P5AST exps) = p5pil <~~ exps
p5pil (OpLeave exps) = p5pil <~~ exps
p5pil (Items exps) = p5pil <~~ exps
p5pil (Bare _) = Noop -- Val (VStr str)
p5pil (OpPrint exps) = fun "print" (p5print <<< exps)
p5pil _ = Noop

fun :: String -> [Exp] -> Exp
fun str args = App (Var ('&':str)) Nothing args

p5print :: P5AST -> [Exp]
p5print (Bare _) = []
p5print (Items xs) = concatMap p5print xs
p5print (OpConst exps) = [Val (VStr $ read (concat (p5str <<< exps)))]
p5print x = error $ show x

p5str :: P5AST -> [String]
p5str (Bare x) = [x]
p5str (Items xs) = p5str <<< xs
p5str (OpStringify xs) = p5str <<< xs
p5str (OpConst xs) = p5const <<< xs
p5str x = error $ show x

p5const :: P5AST -> [String]
p5const (Bare x) = [x]
p5const x = error $ show x

(<<<) :: (P5AST -> [a]) -> [P5AST] -> [a]
f <<< exps = concatMap f exps

flatten :: P5AST -> [P5AST]
flatten (Bare _) = []
flatten (Items exps) = exps
flatten x = [x]

(<~~) :: (P5AST -> Exp) -> [P5AST] -> Exp
f <~~ exps = foldr mergeStmts Noop (map f exps)

{-
import Pugs.Run
import Pugs.AST
import Data.Map

test :: P5AST -> IO Val
test ast = runAST (MkPad empty) (p5pil ast)

ast :: P5AST
ast = P5AST
    [ OpLeave [Items [ ] , Items [ Bare "#!./perl\n\n# $RCSfile: if.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:03 $\n\n" ] , Items [ OpNextstate [] ] , Items [ Bare "print" , OpPrint
        [Items [ ] , Items [ Bare " " , OpConst [Bare "\"" , OpStringify [Bare "" , OpConst [Bare "1..2\\n" ] , Bare "" ] , Bare "\"" ] ] ]
    ] , Items [ Bare ";" , OpNextstate [] , Bare "\n" ] , Items [ OpSassign [Items [ Bare "\n# first test to see if we can run the tests.\n\n" , Bare "$x" ] , Bare " " , Bare "=" , Items [ Bare " " , OpConst [Bare "'test'" ] ] ] ] , Items [ Bare ";" , OpNextstate [] , Bare "\n" ] , Items [ OpCondExpr [Items [ Bare "if" , Bare " " , Bare "(" , OpSeq [Items [ Bare "$x" ] , Bare " " , Bare "eq" , Items [ Bare " " , Bare "$x" ] ] , Bare ")" ] , Items [ Bare " " , Bare "{" , OpScope [Items [ ] , Items [ Bare " " , Bare "print" , OpPrint [Items [ ] , Items [ Bare " " , OpConst [Bare "\"" , OpStringify [Bare "" , OpConst [Bare "ok 1\\n" ] , Bare "" ] , Bare "\"" ] ] ] ] ] , Bare ";" , Bare " " , Bare "}" ] , Items [ Bare " " , Bare "else" , Bare " " , Bare "{" , OpLeave [Items [ ] , Items [ OpNextstate [] ] , Items [ Bare " " , Bare "print" , OpPrint [Items [ ] , Items [ Bare " " , OpConst [Bare "\"" , OpStringify [Bare "" , OpConst [Bare "not ok 1\\n" ] , Bare "" ] , Bare "\"" ] ] ] ] ] , Bare ";" , Bare "}" , Bare "\n" ] ] ] , Items [ OpNextstate [] ] , Items [ OpCondExpr [Items [ Bare "if" , Bare " " , Bare "(" , OpSne [Items [ Bare "$x" ] , Bare " " , Bare "ne" , Items [ Bare " " , Bare "$x" ] ] , Bare ")" ] , Items [ Bare " " , Bare "{" , OpScope [Items [ ] , Items [ Bare " " , Bare "print" , OpPrint [Items [ ] , Items [ Bare " " , OpConst [Bare "\"" , OpStringify [Bare "" , OpConst [Bare "not ok 2\\n" ] , Bare "" ] , Bare "\"" ] ] ] ] ] , Bare ";" , Bare " " , Bare "}" ] , Items [ Bare " " , Bare "else" , Bare " " , Bare "{" , OpLeave [Items [ ] , Items [ OpNextstate [] ] , Items [ Bare " " , Bare "print" , OpPrint [Items [ ] , Items [ Bare " " , OpConst [Bare "\"" , OpStringify [Bare "" , OpConst [Bare "ok 2\\n" ] , Bare "" ] , Bare "\"" ] ] ] ] ] , Bare ";" , Bare "}" , Bare "\n" ] ] ] ]
    ] 

-}