BNFC-meta-0.1: Language/LBNF.hs

{-# LANGUAGE TemplateHaskell #-}

module Language.LBNF (
    compile
  , pp
  , cf, q, qm, Q, errormsg
  , ord, listArray, (!), Err(..), Array, HappyStk(..)
  , Lift (..), Entrypoint(..), Aq(..)
  , module Language.Haskell.Meta.Parse
  , module Language.Haskell.TH.Quote
  
  , dumpAlex, dumpHappy
  ) where

import Language.LBNF.CF
import Language.LBNF.CFtoAbstract
import Language.LBNF.CFtoAlex2
import Language.LBNF.CFtoHappy 
import Language.LBNF.CFtoPrinter
import Language.LBNF.ErrM
import Language.LBNF.GetCF
import Language.LBNF.LiftBNF()
import Language.LBNF.PrintPrelude

import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lift

import Language.Haskell.Meta.Parse

import Text.Happy.Quote
import Text.Alex.Quote

import Data.Array
import Data.Char (ord, toLower)


cf :: QuasiQuoter 
cf = QuasiQuoter cfe cfp where
  cfe s = case getCF s of
    (g,[]) -> lift g
    (_,msgs) -> error $ unlines msgs
  cfp = error "Pattern quoting of grammars is not supported"

qm :: (Entrypoint a, Lift b) => (a -> Q b) -> QuasiQuoter
qm f = QuasiQuoter qExpM (error "Pattern quotes are not supported yet...")
  where
    qExpM s = case parse s of
      Bad e -> error e
      Ok a  -> f a >>= lift

q :: (Entrypoint a, Lift b) => (a -> b) -> QuasiQuoter
q f = QuasiQuoter qExp (error "Pattern quotes are not supported yet...")
  where
    qExp s = case parse s of
      Bad e -> error e
      Ok a  -> lift $ f a

errormsg :: String -> Q a
errormsg s = error s 

pp :: Print a => a -> String
pp = printTree
class Entrypoint a where
  parse :: String -> Err a

class Aq a where
  aq :: a -> ExpQ
  
compose f g = [|$f . $g|]

compile :: CF -> Q [Dec]
compile g = do 
  (d1,tokens) <- cf2Abstract g
  d2 <- cf2Printer g
  d3 <- deriveLiftMany' $ map TyConI tokens 
  dEp <- deriveEps g d1
  dalx <- alexcode g
  dhpy <- happycode g
  return $ d1 
        ++ d2
        ++ tokens
        ++ dEp
        ++ dalx 
        ++ dhpy
        ++ d3

dumpHappy :: CF -> String
dumpHappy = cf2HappyS

dumpAlex :: CF -> String
dumpAlex = cf2alex2

happycode = compileHappy . parseHappy . cf2HappyS

alexcode = compileAlex . parseAlex . cf2alex2

subst _    _  [       ] = []
subst from to xs@(a:as) =
    if isPrefixOf from xs
        then to ++ drop (length from) xs
        else a : subst from to as
    where isPrefixOf as bs = and $ zipWith (==) as bs




deriveEps :: CF -> [Dec] -> Q [Dec]
deriveEps cf ds = do
  d1 <- mapM deriveEp eps
  d2 <- maybe (deriveLiftMany' $ map TyConI ds) (deriveAq cf) (aqSyntax cf)
  d3 <- sequence $ concatMap (spliceQQ $ hasAq cf) eps
  return $ d1 ++ d2 ++ d3
  where
    eps      = filter isNormal $ allEntryPoints cf
    spliceQQ :: Bool -> String -> [Q Dec]
    spliceQQ aq bs = if aq then maybe ([]) go (unAq bs) else go bs where
      go nam = 
        [funD (mkName (initLower nam)) [clause [] (normalB 
          [|q (id :: $(conT typeName) -> $(conT typeName)) |]) []]]
      typeName = mkName bs


deriveEp s = instanceD (cxt []) (appT (conT ''Entrypoint) (conT $ mkName s)) 
  [funD 'parse 
    [clause [] 
      (normalB $ compose (varE $ mkName $ "p"++s) (varE $ mkName $ "tokens")) []
       ]]

deriveAq cf (_,i,a) = (fmap concat $ sequence $ map deriveAqLift $ cf2data cf) >>= addAq where
  addAq ds = do
    v <- newName "a"
    let nAqToken = mkName "AqToken"
    d <- instanceD 
      (cxt []) 
      (appT (conT ''Aq) $ conT nAqToken)
      [funD 'aq [clause [conP nAqToken [varP v]] (normalB $ aqDec (varE v)) []]]
    return $ d:ds
  aqDec v = 
    [|either error return . parseExp . drop $(lie) . reverse . drop $(lae) . reverse $ $(v)|]
  (lie, lae) = (lift $ length i,lift $ length a)


deriveAqLift (c,f_cs) = maybe reg aq (unAq c) where 
  reg = sequence [instanceD (cxt []) (conT ''Lift `appT` typ) [cases >>= funD 'lift ]]
  aq rc = sequence [instanceD (cxt []) (conT ''Lift `appT` typ) [cases >>= funD 'lift ]]
  typ = conT n
  n = mkName c
  cases = do
   s <- newName "s"
   let cons = map doCon f_cs
   return $ cons


deriveAqSpecialLift s = 
 instanceD (cxt []) (conT ''Lift `appT` typ) [cases >>= funD 'lift ] where
  typ = conT n
  n = mkName (rename s)
  aqn = mkName (renameAq s)
  cases = do
    v <- newName "l"
    let aqe = [| return (either error id (parseExp $(varE v))) |]
        aq  = clause [conP aqn [varP v]] (normalB aqe) []
        con = doConSpec s
    return $ aq : [con]


doCon :: (String,[String]) -> Q Clause
doCon (fun,cats) = case unAqs fun of
 Just x -> do    
    v <- newName "l"
    let aqn = mkName fun
        aqe = [|aq $(varE v)|]
    clause [conP aqn [varP v]] (normalB aqe) []
 Nothing -> case unAq fun of
   Nothing -> hlp fun
   Just x  -> if x `elem` specialCatsP then doConSpec x else hlp x
   where 
     hlp real = do
       vs <- mapM newName (map (const "a") cats)
       let c   = mkName real
           aqc = mkName fun
           args = [ [| lift $(varE n) |] | n <- vs ]
           e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) [| conE c |] args
       clause [conP aqc (map varP vs)] (normalB e) []

doConSpec :: String -> Q Clause
doConSpec s = do
  v <- newName "a"
  let
    n = mkName (rename s)
    e = case s of 
      "Integer" -> [| litE (IntegerL $(varE v)) |]
      "Double" -> [| litE (RationalL (toRational $(varE v))) |]
      "String" -> [| litE (StringL $(varE v)) |]
      "Ident" -> [| $(varE $ mkName "lift") $(varE v) |]
      "Char" -> [| litE (charL $(varE v)) |]
      -- _ -> error ( "s )
  clause [conP n [varP v]] (normalB e) []

initLower :: String -> String
initLower []  = error "initLower : Empty list"
initLower (c:cs) = toLower c : cs