{-

cabal install happy alex
        
-}
{
{-# LANGUAGE FlexibleContexts,FlexibleInstances,MultiParamTypeClasses,FunctionalDependencies #-}
module Parser where
import Lexer hiding (main)
import Spec
import Spec0
import Convert0
import Control.Monad.State
    
}
%monad { CM }
%name fregelparser
%partial exprparser expr
%tokentype { Lexeme }
%error { parseError }

%token
-- special patterns (must be defined first)
  T_INT         { (L _ L_CONSTRUCTOR "Int") }
  T_BOOL        { (L _ L_CONSTRUCTOR "Bool") }
  T_DOUBLE      { (L _ L_CONSTRUCTOR "Double") }
  T_STRING      { (L _ L_CONSTRUCTOR "String") }
  T_PAIR        { (L _ L_CONSTRUCTOR "Pair") }
  A_SUM         { (L _ L_IDENT "sum") }
  A_PROD        { (L _ L_IDENT "prod") }
  A_MINIMUM     { (L _ L_IDENT "minimum") }
  A_MAXIMUM     { (L _ L_IDENT "maximum") }
  A_OR          { (L _ L_IDENT "or") }
  A_AND         { (L _ L_IDENT "and") }
  A_RANDOM      { (L _ L_IDENT "random") }
  G_FREGEL      { (L _ L_IDENT "fregel") }
  G_GMAP        { (L _ L_IDENT "gmap") }
  G_GZIP        { (L _ L_IDENT "gzip") }
  G_GITER       { (L _ L_IDENT "giter") }
  TC_FIX        { (L _ L_CONSTRUCTOR "Fix") }
  TC_ITER       { (L _ L_CONSTRUCTOR "Iter") }
  TC_UNTIL      { (L _ L_CONSTRUCTOR "Until") }
  TC_WHILE      { (L _ L_CONSTRUCTOR "While") }
-- normal tokens
  DATA          { (L _ L_DATA _) }
  DERIVING      { (L _ L_DERIVING _) }
  LET           { (L _ L_LET _) }
  IN            { (L _ L_IN _) }
  IF            { (L _ L_IF _) }
  THEN          { (L _ L_THEN _) }
  ELSE          { (L _ L_ELSE _) }
  CURR          { (L _ L_CURR _) }
  PREV          { (L _ L_PREV _) }
  VAL           { (L _ L_VAL _) }
  IS            { (L _ L_IS _) }
  RS            { (L _ L_RS _) }
  GOF           { (L _ L_GOF _) }
  EQUAL         { (L _ L_EQUAL _) }
  DBLCOLON      { (L _ L_DBLCOLON _) }
  COMMA         { (L _ L_COMMA _) }
  SEMICOLON     { (L _ L_SEMICOLON _) }
  BACKSLASH     { (L _ L_BACKSLASH _) }
  RARROW        { (L _ L_RARROW _) }
  LARROW        { (L _ L_LARROW _) }
  DOTHAT        { (L _ L_DOTHAT _) }
  PIPE          { (L _ L_PIPE _) }
  DBLAND        { (L _ L_DBLAND _) }
  DBLOR         { (L _ L_DBLOR _) }
  EQ            { (L _ L_EQ _) }
  NE            { (L _ L_NE _) }
  LT            { (L _ L_LT _) }
  LE            { (L _ L_LE _) }
  GT            { (L _ L_GT _) }
  GE            { (L _ L_GE _) }
  PLUS          { (L _ L_PLUS _) }
  MINUS         { (L _ L_MINUS _) }
  AST           { (L _ L_AST _) }
  SLASH         { (L _ L_SLASH _) }
  BACKQUOTE     { (L _ L_BACKQUOTE _) }
  LPAREN        { (L _ L_LPAREN _) }  
  RPAREN        { (L _ L_RPAREN _) }
  LBRACE        { (L _ L_LBRACE _) }  
  RBRACE        { (L _ L_RBRACE _) }
  LBRACKET      { (L _ L_LBRACKET _) }  
  RBRACKET      { (L _ L_RBRACKET _) }
  BOOL          { (L _ L_BOOL _) }
  INT           { (L _ L_INT _) }
  FLOAT         { (L _ L_FLOAT _) }
  STRING        { (L _ L_STRING _) }
  IDENT         { (L _ L_IDENT _) }
  CONSTRUCTOR   { (L _ L_CONSTRUCTOR _) }


%%
-- the start ;  left-recursion is more efficient for Happy (but the list needs to be reversed)
programSpecs :: { [DProgramSpec0 Pos] }
programSpecs : 
   programSpec                        { [$1]  }
 | programSpecs SEMICOLON programSpec { $3:$1 }

programSpec :: { DProgramSpec0 Pos }
programSpec :
   recordSpecs smplDef { DProgramSpec0 (reverse $1) $2 (if $1 == [] then getData $2 else getData (head $1)) }

recordSpecs :: { [ DRecordSpec Pos] }
recordSpecs :
   {- empty -}               { [ ] }
 | recordSpecs recordSpec    { $2:$1 }

recordSpec :: { DRecordSpec Pos }
recordSpec :
   DATA constructor EQUAL constructor LBRACE fieldSpecs RBRACE opt_deriving { DRecordSpec $4 (reverse $6) (getData $1) } 

fieldSpecs :: { [(DField Pos, DType Pos)] }
fieldSpecs :
   fieldSpec                    { [$1] }
 | fieldSpecs COMMA fieldSpec   { $3:$1 }

fieldSpec :: { (DField Pos, DType Pos) }
fieldSpec : 
   field DBLCOLON type { ($1, $3) }

field :: { DField Pos }
field :
   IDENT  { DField (strToken $1) (getData $1)}

type :: { DType Pos }
type :
   T_INT               { DTInt (getData $1) }
 | T_BOOL              { DTBool (getData $1) }
 | T_STRING            { DTString (getData $1) }
 | T_DOUBLE            { DTDouble (getData $1) }
 | T_PAIR type type    { DTRecord (DConstructor "Pair" (getData $1)) [$2, $3] (getData $1) }
 | LPAREN type RPAREN  { $2 }
 | LPAREN types RPAREN { DTTuple (reverse $2) (getData $1) }
 | CONSTRUCTOR         { DTRecord (DConstructor (strToken $1) (getData $1)) [] (getData $1) }

types :: { [DType Pos] }
types :
   type COMMA type   { [$3, $1]}
 | types COMMA type  { $3:$1 }

-- ignored
opt_deriving :: { () }
opt_deriving :
    {- empty -}                          { () }
  | DERIVING CONSTRUCTOR                 { () }
  | DERIVING LPAREN deriving_constructors RPAREN  { () }

deriving_constructors :: { () }
deriving_constructors :
   CONSTRUCTOR                             { () }
 | deriving_constructors COMMA CONSTRUCTOR { () }

exprWithSmplDefs :: { ([DSmplDef0 Pos], DExpr0 Pos) }
exprWithSmplDefs :
   LET smplDefs IN expr { (reverse $2, $4) }
 | expr                 { ([], $1) }

smplDefs :: { [DSmplDef0 Pos] }
smplDefs :
   smplDef                    { [$1] }
 | smplDefs SEMICOLON smplDef { $3:$1 } 

smplDef :: { DSmplDef0 Pos }
smplDef :
   defFun      { $1 }
 | defVar      { $1 }
 | defTuple    { $1 }
 | defVertComp { $1 } 

defFun :: { DSmplDef0 Pos }
defFun :
   var vars EQUAL exprWithSmplDefs  { DDefFun0 $1 (reverse $2) (fst $4) (snd $4) (getData $1) }

defVar :: { DSmplDef0 Pos }
defVar :
   var EQUAL exprWithSmplDefs       { DDefVar0 $1 (fst $3) (snd $3) (getData $1) }

defTuple :: { DSmplDef0 Pos }
defTuple :
   LPAREN csVars RPAREN EQUAL exprWithSmplDefs { DDefTuple0 (reverse $2) (fst $5) (snd $5) (getData $1) }

defVertComp :: { DSmplDef0 Pos }
defVertComp :
   var var PREV CURR EQUAL exprWithSmplDefs {% mustbe $2 "v" >> return (DDefVertComp0 $1 (fst $6) (snd $6) (getData $1)) }

var :: { DVar Pos }
var :
   IDENT  { DVar (strToken $1) (getData $1)}

vars :: { [DVar Pos] }
vars :
   var      { [$1] }
 | vars var { $2:$1 }

csVars :: { [DVar Pos] }
csVars :
   var COMMA var    { [$3,$1] }
 | csVars COMMA var { $3:$1 }

-- expression hierarchy
expr :: { DExpr0 Pos }
expr :
   expr8                                 { $1 }

expr8 :: { DExpr0 Pos }
expr8 :
   IF expr7 THEN expr7 ELSE expr7        { DIf0 $2 $4 $6 (getData $1) }    
 | expr7                                 { $1 }

expr7 :: { DExpr0 Pos }
expr7 :
   expr7 DBLOR expr6                     { DFunAp0 (DBinOp "||" (getData $2)) [$1,$3] (getData $1) }
 | expr6                                 { $1 }

expr6 :: { DExpr0 Pos }
expr6 :
   expr6 DBLAND expr5                    { DFunAp0 (DBinOp "&&" (getData $2)) [$1,$3] (getData $1) }
 | expr5                                 { $1 }

expr5 :: { DExpr0 Pos }
expr5 :
   expr4 LE expr4                        { DFunAp0 (DBinOp "<=" (getData $2)) [$1,$3] (getData $1) }
 | expr4 GE expr4                        { DFunAp0 (DBinOp ">=" (getData $2)) [$1,$3] (getData $1) }
 | expr4 EQ expr4                        { DFunAp0 (DBinOp "==" (getData $2)) [$1,$3] (getData $1) }
 | expr4 NE expr4                        { DFunAp0 (DBinOp "!=" (getData $2)) [$1,$3] (getData $1) }
 | expr4 GT expr4                        { DFunAp0 (DBinOp ">" (getData $2)) [$1,$3] (getData $1) }
 | expr4 LT expr4                        { DFunAp0 (DBinOp "<" (getData $2)) [$1,$3] (getData $1) }
 | expr4                                 { $1 }

expr4 :: { DExpr0 Pos }
expr4 :
   expr3 BACKQUOTE var BACKQUOTE expr3   { DFunAp0 (v2f $3) [$1,$5] (getData $1) }
 | expr4 op4 expr3                       { DFunAp0 (DBinOp $2 (getData $1)) [$1, $3] (getData $1) }
 | expr3                                 { $1 }

op4 :: { String }
op4 :
   PLUS                                  { "+" }
 | MINUS                                 { "-" }

expr3 :: { DExpr0 Pos }
expr3 :
   expr3 op3 expr2                       { DFunAp0 (DBinOp $2 (getData $1)) [$1, $3] (getData $1) }
 | MINUS expr2                           { if isConstNum $2 then negConst $2 else DFunAp0 (DFun "neg" (getData $1)) [$2] (getData $1) }
 | expr2                                 { $1 }

op3 :: { String }
op3 :
   AST                                   { "*" }
 | SLASH                                 { "/" }

expr2 :: { DExpr0 Pos }
expr2 :
   tableExpr DOTHAT dhsFields            { DFieldAcc0 $1 (reverse $3) (getData $1) }
 | tableExpr                             { DFieldAcc0 $1 [] (getData $1) }
 | var DOTHAT dhsFields                  {% mustbe $1 "e" >> return (DFieldAccE0 (DEdge (getData $1)) (reverse $3) (getData $1)) }
 | expr1                                 { $1 }

dhsFields :: { [DField Pos] }
dhsFields :
   field                                 { [$1] }
 | dhsFields DOTHAT field                { $3:$1 }

tableExpr :: { DTableExpr Pos }
tableExpr :
   CURR var                              { DCurr $2 (getData $1) }
 | PREV var                              { DPrev $2 (getData $1) }
 | VAL  var                              { DVal  $2 (getData $1) }
 
expr1 :: { DExpr0 Pos }
expr1 : 
   var expr0s                            { DFunAp0 (v2f $1) (reverse $2) (getData $1) }
 | constructor expr0s                    { DConsAp0 $1 (reverse $2) (getData $1) }
 | agg LBRACKET expr PIPE gen csExprs RBRACKET { DAggr0 $1 $3 $5 (reverse $6) (getData $1) }
 | expr0                                 { $1 }
 | G_FREGEL var var termination var      { DPregel0 $2 $3 $4 $5 (getData $1) }
 | G_GMAP var var                        { DGMap0 $2 $3 (getData $1) }
 | G_GZIP var var                        { DGZip0 $2 $3 (getData $1) }
 | G_GITER var var termination var       { DGIter0 $2 $3 $4 $5 (getData $1) }

termination :: { DTermination0 Pos }
termination :
   TC_FIX                            { DTermF0 (getData $1)    }
 | LPAREN TC_ITER expr RPAREN        { DTermI0 $3 (getData $1) }
 | LPAREN TC_UNTIL predExpr RPAREN   { DTermU0 $3 (getData $1) }
 | LPAREN TC_WHILE predExpr RPAREN   { DTermU0 (DFunAp0 (DFun "not" (getData $1)) [$3] (getData $1)) (getData $1) } 
 | LPAREN termination RPAREN         { $2       }

predExpr :: { DExpr0 Pos }
predExpr :
  LPAREN BACKSLASH var RARROW expr RPAREN {% mustbe $3 "g" >> return $5 }

expr0 :: { DExpr0 Pos }
expr0 :
   constVal                              { DCExp0 $1 (getData $1) }
 | var                                   { DVExp0 $1 (getData $1) }
 | LPAREN expr RPAREN                    { $2          }
 | LPAREN expr COMMA expr csExprs RPAREN { DTuple0 ($2:$4:reverse $5) (getData $1) }

expr0s :: { [DExpr0 Pos] }
expr0s :
   expr0                                 { [$1] }
 | expr0s expr0                          { $2:$1 }

csExprs :: { [DExpr0 Pos] }
csExprs :
   {- empty -}                           { [] }
 | csExprs COMMA expr                    { $3:$1 }

gen :: { DGen Pos }
gen :
   LPAREN var COMMA var RPAREN LARROW IS var {% mustbe $2 "e" >> mustbe $4 "u" >> mustbe $8 "v" >> return (DGenI (getData $1)) }
 | LPAREN var COMMA var RPAREN LARROW RS var {% mustbe $2 "e" >> mustbe $4 "u" >> mustbe $8 "v" >> return (DGenO (getData $1)) }
 | var LARROW GOF var                        {% mustbe $1 "u" >> mustbe $4 "v" >> return (DGenG (getData $1)) }
 | var LARROW var                            {% mustbe $1 "u" >> mustbe $3 "v" >> return (DGenG (getData $1)) }

agg :: { DAgg0 Pos }
agg :
   A_MINIMUM     { DAggMin0 (getData $1)  }
 | A_MAXIMUM     { DAggMax0 (getData $1)  }
 | A_SUM         { DAggSum0 (getData $1)  }
 | A_PROD        { DAggProd0 (getData $1) }
 | A_AND         { DAggAnd0 (getData $1)  }
 | A_OR          { DAggOr0 (getData $1)   }
 | A_RANDOM expr { DAggChoice0 $2 (getData $1)  }

constructor :: { DConstructor Pos }
constructor :
   CONSTRUCTOR { DConstructor (strToken $1) (getData $1) }

constVal :: { DConst Pos }
constVal :
   INT    { DCInt    (readToken $1) (getData $1) }
 | FLOAT  { DCDouble (readTokenF $1) (getData $1) }
 | BOOL   { DCBool   (readToken $1) (getData $1) }
 | STRING { DCString (strToken $1) (getData $1) }


{ -- misc functions

-- extracs the string from a token
strToken :: Lexeme -> String
strToken (L _ _ s) = s

-- reads data from a token
readToken :: Read a => Lexeme -> a
readToken = read . strToken

-- reads data from a token
readTokenF :: Lexeme -> Double
readTokenF = read . correct . strToken
  where correct str =   -- workaround for "0."
          let r = reverse str
          in reverse $ (if head r == '.' then ('0':) else id) r

instance DAdditionalData Lexeme Pos where
  getData (L p t s) = p
  setData p (L _ t s) = L p t s

-- a token must be a specific name
mustbe :: DVar Pos -> String -> CM ()
mustbe (DVar name p) str = if name == str
                            then return ()
                            else error $ "Parse error: variable name must be " ++ str ++ " at " ++ showPosn p
              
parseError :: [Lexeme] -> a
parseError ((L p t s):ts) = error $ "Parse error: " ++ s ++ " at " ++ showPosn p

-- to make negative integral/float literals                                     
isConstNum :: DExpr0 Pos -> Bool
isConstNum (DCExp0 (DCInt _ _) _) = True
isConstNum (DCExp0 (DCDouble _ _) _) = True
isConstNum _ = False

negConst :: DExpr0 Pos -> DExpr0 Pos
negConst (DCExp0 (DCInt i a) b) = (DCExp0 (DCInt (-i) a) b)
negConst (DCExp0 (DCDouble d a) b) = (DCExp0 (DCDouble (-d) a) b)

-- currently, these are meaningless
data Params = Params 
            deriving (Eq, Show)

initParams = Params 

data CompilerState  = CompilerState 

type CM a = State CompilerState a

runCM m ps = runState m (initState ps)
    
initState ps = CompilerState

main = do str <- getContents
          let ast0 = parseString0 str
              ast = map convert0 ast0
          print ast0
          print ast

{- for test use
main = do getContents >>= mapM_ (\file -> check file >>= putStrLn . show) . lines
-- checking function: parse = parse . prettyPrint . parse ? 
check file = 
  do ast <- parseFile file
     print ast
     let pp = foldr (\x y -> x ++ "\n" ++ y) "" (map ppAST0 ast)
     putStrLn pp
     let ast2 = parseString0 pp
     print ast2
     return (map (mapData (\_ -> "")) ast == map (mapData (\_ -> "")) ast2)  --ignore line/pos
-}

--- misc functions to be used by other modules

parseStringExpr0 str = 
      let ts = snd (right (scanner str))
          ast = fst $ runCM (exprparser ts) initParams   
      in ast

parseString0 :: String -> [DProgramSpec0 Pos]
parseString0 str = 
      let ts = snd (right (scanner str))
          ast = fst $ runCM (fregelparser ts) initParams   
      in ast

parseString :: String -> [DProgramSpec String]
parseString str = map (mapData (\_ -> "")) $ map convert0 $ parseString0 str
         
parseFile file =
         do str <- readFile file
            return $ parseString str 
         
processFile file =
  do ast <- parseFile file
     print ast

parseFile' file = 
  do ast <- parseFile file
     return ast

parseFile'' file = 
  do asts <- parseFile file
     return (propRecs asts)
  where propRecs xs =
          let rss = concatMap (\(DProgramSpec rs _ _) -> rs) xs
          in map (\(DProgramSpec _ x a) -> DProgramSpec rss x a) xs

parseString' ss = parseString ss

}