module Language.LBNF.Compiletime(
HappyStk(..)
, ord
, listArray
, (!)
, Array
, printTree
, doc
, concatD
, Print(..)
, prPrec
, PrintPlain(..)
, parseToQuoter, parseToMonQuoter
, ParseMonad(..)
, errq
, Q
, BNFC_QQType(..), appEPAll, appEPAllL, fromString, fromLit, fromToken, fromPositionToken
, 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 ((>=>),liftM)
import Language.Haskell.TH.Syntax
import Language.Haskell.Meta.Parse
data BNFC_QQType =
QQApp (String,LocType) [BNFC_QQType] |
QQAq (Q Exp, Q Pat) |
QQList [BNFC_QQType] |
QQLit Lit |
QQPosT (Int,Int) (String,LocType) String
type LocType = (String,String)
errq :: (String -> a) -> ParseMonad a -> Q a
errq e = return . err e
appEPAll :: LocType -> String -> [BNFC_QQType] -> BNFC_QQType
appEPAll loc s l = QQApp (s,loc) l
appEPAllL :: LocType -> [BNFC_QQType] -> BNFC_QQType
appEPAllL loc l = QQList l
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
class IsChar a where
toChar :: a -> Char
instance IsChar Char where
toChar = id
instance IsChar a => Literal [a] where
lit = StringL . map toChar
fromLit :: Literal a => LocType -> a -> BNFC_QQType
fromLit l a = QQLit $ lit a
fromString l s = fromLit l s
fromToken l t s = QQApp (t,l) [QQLit $ lit s]
fromPositionToken :: LocType -> String -> ((Int,Int),String) -> BNFC_QQType
fromPositionToken l t v@(pos,s) = QQPosT pos (t,l) s
qualify "" f = f
qualify _ f@"[]" = f
qualify _ f@":" = f
qualify m f = m ++ "." ++ f
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 :: (String -> ParseMonad BNFC_QQType) -> QuasiQuoter
parseToQuoter p = QuasiQuoter {
quoteExp = handle . p >=> toQExp,
quotePat = handle . p >=> toQPat
}
parseToMonQuoter :: (String -> ParseMonad BNFC_QQType) -> QuasiQuoter
parseToMonQuoter p = QuasiQuoter {
quoteExp = handle . p >=> toQMExp,
quotePat = handle . p >=> toQPat
}
toQExp :: BNFC_QQType -> Q Exp
toQExp qq = case qq of
QQApp (s,l) qs -> do
const <- mkGName l s
foldl appE (conE const) (map toQExp qs)
QQAq p -> fst p
QQList qs -> mapM toQExp qs >>= \qs' -> case qs' of
[ListE es, e] -> listE (map return $ es ++ [e])
[ConE _,e] -> listE $ [return e]
a -> listE $ map return a
QQLit l -> litE l
QQPosT pos (t,l) s -> do
constr <- mkGName l t
appE (conE constr) (lift (pos,s))
toQMExp :: BNFC_QQType -> Q Exp
toQMExp qq = case qq of
QQApp (s,l) qs -> do
const <- mkGName l s
foldl mAppE (returnE $ conE const) (map toQMExp qs)
QQAq p -> fst p
QQList qs -> mapM toQMExp qs >>= \qs' -> case qs' of
[ListE es, e] -> sequenceE $ listE (map return $ es ++ [e])
[ConE _,e] -> sequenceE $ listE $ [return e]
a -> sequenceE $ listE $ map return a
QQLit l -> returnE $ litE l
QQPosT pos (t,l) s -> do
constr <- mkGName l t
returnE $ appE (conE constr) (lift (pos,s))
returnE = appE (varE 'return)
sequenceE = appE (varE 'sequence)
mAppE :: Q Exp -> Q Exp -> Q Exp
mAppE mf ma = [| $mf >>= flip liftM $ma |]
toQPat :: BNFC_QQType -> Q Pat
toQPat qq = case qq of
QQApp (s,l) qs -> do
const <- mkGName l s
conP const (map toQPat qs)
QQAq p -> snd p
QQList qs -> mapM toQPat qs >>= \qs' -> case qs' of
[p,ListP ps] -> listP $ map return $ p : ps
[x] -> listP [return x]
QQLit l -> litP l
QQPosT (p1,p2) (t,l) s -> mkGName l t >>= flip conP
[tupP [
tupP [litP $ IntegerL $ toInteger p1, litP $ IntegerL $ toInteger p2],
litP (lit s)
]]
printAq :: Print a => a -> BNFC_QQType
printAq a = stringAq $ printTree a
stringAq :: String -> BNFC_QQType
stringAq s = QQAq (
either error return . parseExp $ s,
either error return . parsePat $ s)
handle :: ParseMonad BNFC_QQType -> Q BNFC_QQType
handle (Bad s) = fail s
handle (Ok a) = return a