BNFC-meta 0.2.0.2 → 0.2.1

raw patch · 4 files changed

+115/−33 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• BNFC-meta.cabal +1/−1
• Language/LBNF/CFtoHappy.hs +5/−2
• Language/LBNF/Compiletime.hs +108/−29
• Language/LBNF/Grammar.hs +1/−1

@@ -1,5 +1,5 @@ Name:		BNFC-meta-version:	0.2.0.2+version:	0.2.1 cabal-Version:  >= 1.6 build-type:     Simple license:        GPL-2

@@ -53,6 +53,7 @@ appEPAllL = "appEPAllL myLocation "
 appEPAll  = "appEPAll myLocation "
 fromToken = "fromToken myLocation "
+fromPositionToken = "fromPositionToken myLocation "
 fromLitteral = "fromLit myLocation "
 
 -- Happy mode
@@ -332,10 +333,12 @@       _         -> unlines
         [ cat ++ "    :: { " ++ cat ++ "} : L_" ++ fun ++ " { " ++ fun ++ " ("++ posn ++ "$1)}"
         , "QQ_"++cat ++ " :: { BNFC_QQType }"
-        , "QQ_"++cat ++ " : L_" ++ fun ++ " {"++fromToken ++" \""++ fun ++"\" $1}"
+        , "QQ_"++cat ++ " : L_" ++ fun ++ " {"++fromToken' ++" \""++ fun ++"\" ("++ posn ++ " $1 ) }"
         ] ++  aqrule cat
       where
-         posn = if isPositionCat cf cat then "mkPosToken " else ""
+         posn = if isPos then "mkPosToken " else ""
+         fromToken' = if isPos then fromPositionToken else fromToken
+         isPos = isPositionCat cf cat
    aqrule = maybe (const "") rule $ aqSyntax cf 
    rule (b,i,a) = twoRules where
      open     = "'"++b++"' " ++ body 

@@ -1,3 +1,4 @@+{-#LANGUAGE TemplateHaskell#-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-}
 module Language.LBNF.Compiletime(
   -- * Happy and Alex runtimes
@@ -5,11 +6,7 @@   , ord
   , listArray
   , (!)
-  , Array
-  , parseToQuoter
-  , ParseMonad(..)
-  , errq
-  
+  , Array  
   -- * Pretty printing runtimes
   , printTree
   , doc
@@ -19,8 +16,11 @@   , PrintPlain(..)
 
   -- * Quasi quoting runtimes
+  , parseToQuoter, parseToMonQuoter
+  , ParseMonad(..)
+  , errq
   , Q
-  , BNFC_QQType, appEPAll, appEPAllL, fromLit, fromString, fromToken
+  , BNFC_QQType(..), appEPAll, appEPAllL, fromString, fromLit, fromToken, fromPositionToken
   , Lift (..)
   , printAq
   , stringAq
@@ -34,7 +34,7 @@ import Language.Haskell.TH
 import Language.Haskell.TH.Quote
 
-import Control.Monad ((>=>))
+import Control.Monad ((>=>),liftM)
 import Language.Haskell.TH.Syntax
 import Language.Haskell.Meta.Parse
 
@@ -42,8 +42,14 @@ -- import qualified Language.Haskell.Exts.Parser as Hs
 
 
+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 BNFC_QQType = (Q Exp, Q Pat)
+
 type LocType = (String,String)
 
 
@@ -54,21 +60,11 @@ 
 -- 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)
+appEPAll loc s l = QQApp (s,loc) l
 
 
-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] 
+appEPAllL :: LocType -> [BNFC_QQType] -> BNFC_QQType
+appEPAllL loc l = QQList l
 
 
 class Literal a where
@@ -83,15 +79,31 @@ 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 = (litE $ lit a,litP $ lit a)
+fromLit l a = QQLit $ 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])
+fromString l s = fromLit l s -- (litE $ StringL s,litP $ StringL s)
 
 
+fromToken l t s = QQApp (t,l) [QQLit $ lit s]
+--    (
+--    appE (mkGName l t >>= conE)(litE $ StringL s), 
+--    mkGName l t >>= flip conP [litP $ StringL 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
@@ -109,22 +121,89 @@ 
 
 
+parseToQuoter :: (String -> ParseMonad BNFC_QQType) -> QuasiQuoter
+parseToQuoter p = QuasiQuoter {
+  quoteExp = handle . p >=> toQExp,
+  quotePat = handle . p >=> toQPat
+  }
 
-parseToQuoter p = QuasiQuoter {quoteExp = fst . handle . p, quotePat = snd . handle . p}
+parseToMonQuoter :: (String -> ParseMonad BNFC_QQType) -> QuasiQuoter
+parseToMonQuoter p = QuasiQuoter {
+  quoteExp = handle . p >=> toQMExp,
+  quotePat = handle . p >=> toQPat
+  }
 
+ -- {quoteExp = fst . handle . p, quotePat = snd . handle . p}
 
+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 = (
+stringAq s = QQAq (
   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
+handle :: ParseMonad BNFC_QQType -> Q BNFC_QQType
+handle (Bad s) = fail s
+handle (Ok a)  = return a
 
 
 

@@ -5444,7 +5444,7 @@ 
 myLexer = tokens
 
-myLocation = ("BNFC-meta-0.2.0.2","Language.LBNF.Grammar")
+myLocation = ("BNFC-meta-0.2.1","Language.LBNF.Grammar")
 
 {-# LINE 1 "templates\GenericTemplate.hs" #-}
 {-# LINE 1 "templates\\GenericTemplate.hs" #-}