module Language.LBNF.Compiletime(
HappyStk(..)
, ord
, listArray
, (!)
, Array
, parseToQuoter
, ParseMonad(..)
, errq
, printTree
, doc
, concatD
, Print(..)
, prPrec
, PrintPlain(..)
, 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
type BNFC_QQType = (Q Exp, Q Pat)
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 = 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])
appEAllL l [ConE _,e] = listE $ [return e]
appEAllL l a = listE $ map return a
appPAllL l [p,ListP ps] = listP $ map return $ p : 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
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