{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module Language.LBNF.Compiletime(
  -- * Happy and Alex runtimes
  HappyStk(..)
  , ord
  , listArray
  , (!)
  , Array
  , parseToQuoter
  , ParseMonad(..)
  , errq
  
  -- * Pretty printing runtimes
  , printTree
  , doc
  , concatD
  , Print(..)
  , prPrec
  , PrintPlain(..)

  -- * Quasi quoting runtimes
  , Q
  , BNFC_QQType, appEPAll, appEPAllL, fromLit, fromString, fromToken
  , Lift (..)
  , printAq
  , stringAq
  ) where

import Language.LBNF.Runtime
import Text.Happy.Quote(HappyStk(..))
import Data.Array(listArray, (!), Array)
import Data.Char

import Language.Haskell.TH
import Language.Haskell.TH.Quote

import Control.Monad ((>=>))
import Language.Haskell.TH.Syntax
import Language.Haskell.Meta.Parse


-- import qualified Language.Haskell.Exts.Parser as Hs



type BNFC_QQType = (Q Exp, Q Pat)
type LocType = (String,String)


errq :: (String -> a) -> ParseMonad a -> Q a
errq e = return . err e



-- appEAll :: [TH_Exp] -> TH_Exp
appEPAll :: LocType -> String -> [BNFC_QQType] -> BNFC_QQType
appEPAll loc s l = let (es,ps) = unzip l in (
    foldl appE (mkGName loc s >>= conE) es, 
    mkGName loc s >>= flip conP ps)

appEPAllL :: LocType -> [BNFC_QQType] -> BNFC_QQType
appEPAllL loc l = let (es,ps) = unzip l in
  (sequence es >>= appEAllL loc, sequence ps >>= appPAllL loc)


appEAllL l [ListE es, e] = listE (map return $ es ++ [e]) -- FIXME: Efficiency
appEAllL l [ConE _,e]   = listE $ [return e] 
appEAllL l a = listE $ map return a

appPAllL l [p,ListP ps] = listP $ map return $ p : ps -- ConP cons_name ps
appPAllL l [x]          = listP [return x] 


class Literal a where
  lit :: a -> Lit
  
instance Literal Double where
  lit = RationalL . toRational

instance Literal Integer where
  lit = IntegerL

instance Literal Char where
  lit = CharL


fromLit :: Literal a => LocType -> a -> BNFC_QQType
fromLit l a = (litE $ lit a,litP $ lit a)

fromString l s = (litE $ StringL s,litP $ StringL s)

fromToken l t s = (appE (mkGName l t >>= conE) (litE $ StringL s), mkGName l t >>= flip conP [litP $ StringL s])


qualify "" f     = f
qualify _ f@"[]" = f
qualify _ f@":"  = f
qualify m  f     = m ++ "." ++ f

-- Dynamic names
-- mkGName :: LocType -> String -> Q Name
-- mkGName (p,m) s = return $ mkName $ qualify m s 

-- Static names
mkGName (p,m) ":" = return $ mkName ":"
mkGName (p,m) "[]" = return $ mkName "[]"
mkGName (p,m) n = return $ Name (mkOccName n) $ 
    NameG DataName (mkPkgName $ p) (mkModName $ m)




parseToQuoter p = QuasiQuoter {quoteExp = fst . handle . p, quotePat = snd . handle . p}


printAq :: Print a => a -> BNFC_QQType
printAq a = stringAq $ printTree a

stringAq :: String -> BNFC_QQType
stringAq s = (
  either error return . parseExp $ s, 
  either error return . parsePat $ s)


handle :: ParseMonad BNFC_QQType -> (Q Exp,Q Pat)
handle (Bad s) = (fail s,fail s)
handle (Ok a)  = a