happy-meta 0.1.1 → 0.2

raw patch · 5 files changed

+88/−51 lines, 5 filesdep −th-liftdep ~haskell-src-meta

Dependencies removed: th-lift

Dependency ranges changed: haskell-src-meta

Files

• Text/Happy/Quote.hs +0/−41
• happy-meta.cabal +2/−3
• src/LALR.lhs +7/−1
• src/Text/Happy.hs +7/−6
• src/Text/Happy/Quote.hs +72/−0

@@ -1,41 +0,0 @@-module Text.Happy.Quote (
-    parseHappy
-  , compileHappy
-  , happy
-  , HappyStk(..)
-  ) where
-
-import Text.Happy(runHappy)
-import Text.Happy.HappyTemplate
-
-import Language.Haskell.TH.Quote
-import Language.Haskell.TH
-import Language.Haskell.TH.Lift
-
-import Language.Haskell.Meta
-
--- Runtime
-data HappyStk a = HappyStk a (HappyStk a)
-infixr 9 `HappyStk`
-
-
-type Happy = String
-
-compileHappy :: Happy -> Q [Dec]
-compileHappy = return . either error id . parseDecs
-
-happy :: QuasiQuoter
-happy = QuasiQuoter (lift . parseHappy) (error "happy: pattern quoting is not supported") 
-
-parseHappy :: String -> Happy
-parseHappy s = subst old "" $ fst (runHappy [] s) ++ "\n" ++ happyTemplate
-  where
-    old = unlines ["infixr 9 `HappyStk`",
-                     "data HappyStk a = HappyStk a (HappyStk a)"]
-
-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

@@ -1,5 +1,5 @@ Name:                happy-meta
-Version:             0.1.1
+Version:             0.2
 Synopsis:            Quasi-quoter for Happy parsers
 -- Description:         
 License:             BSD3
@@ -21,8 +21,7 @@ 
   Build-depends:
       template-haskell >=2.4&&<2.5
-    , th-lift >=0.5&&<0.6
-    , haskell-src-meta >=0.1.1&&<0.2
+    , haskell-src-meta >=0.3&&<1.0
     , base >= 4.2 && < 5
     , array, containers
     , mtl >= 1.0

@@ -213,19 +213,25 @@ >	    (map (\i -> let i' = closure0 g precalcClosures i in >	    		[ (x,gotoClosure g i' x) | x <- tokens ]) newSets) +% This comment causes some problems with Haddock+\begin{code}+{- Next, we assign each new set a number, which is the index of this set in the list of sets comprising all the sets generated so far plus those generated in this iteration.  We also filter out those sets that are new, i.e. don't exist in the current list of sets, so that they can be added. +This comment causes some problem with haddock. We also have to make sure that there are no duplicate sets in the *current* batch of goto(I,X) sets, as this could be disastrous.  I think I've squished this one with the '++ reverse newSets' in-numberSets.+numberSets.   numberSets is built this way so we can use it quite neatly with a foldr. Unfortunately, the code's a little opaque.+-}+\end{code}  >	numberSets  >		:: [(Name,Set Lr0Item)] 

@@ -1,4 +1,4 @@-module Text.Happy (runHappy, CLIFlags(..)) where+module Text.Happy (runHappy, CLIFlags(..), HappyInfo(..)) where  import ProduceCode import Parser@@ -13,14 +13,15 @@ import Data.Array( assocs, elems, (!) ) import Data.List( nub ) +data HappyInfo = HappyInfo { unused :: ([Int],[String]), sr :: Int, rr :: Int}   runHappy :: [CLIFlags]             -> String-            -> (String, ([Int], [String]))+            -> Either String (String, HappyInfo) runHappy cli s =   case runP ourParser s 1 of-  FailP err -> die (err)-  OkP abssyn@(AbsSyn _ _ _ tl) -> +  FailP err -> Left err+  OkP abssyn@(AbsSyn _ _ _ tl) -> Right $     case {-# SCC "Mangler" #-} (mangler "" abssyn) of       Failed e -> die (unlines e ++ "\n")       Succeeded g -> let @@ -32,7 +33,7 @@         items2	= {-# SCC "Merge" #-} (mergeLookaheadInfo la sets)         goto   	= {-# SCC "Goto" #-} (genGotoTable g sets)         action 	= {-# SCC "Action" #-} (genActionTable g first items2)---        (conflictArray,(sr,rr))   = {-# SCC "Conflict" #-} (countConflicts action)+        (conflictArray,(sr,rr))   = {-# SCC "Conflict" #-} (countConflicts action)  	reduction_filter | OptGLR `elem` cli = any_reduction 	                 | otherwise         = first_reduction@@ -59,7 +60,7 @@           opt_ghc           opt_strict         in-          (outfile,((unused_rules, unused_terminals)))+          (outfile,HappyInfo (unused_rules, unused_terminals) sr rr)   

@@ -0,0 +1,72 @@+module Text.Happy.Quote (
+    parseHappy
+  , parseHappyInfo
+  , compileHappy
+  , happy
+  , HappyStk(..)
+  , HappyInfo
+  , happyWarn
+  ) where
+
+import Text.Happy(runHappy, HappyInfo(..))
+import Text.Happy.HappyTemplate
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH
+
+import Language.Haskell.Meta
+
+import Control.Monad(when)
+import System.IO(hPutStrLn,stderr)
+
+-- Runtime (The infixr declaration can not be spliced by TH)
+data HappyStk a = HappyStk a (HappyStk a)
+infixr 9 `HappyStk`
+
+
+type Happy = String
+
+compileHappy :: Happy -> Q [Dec]
+compileHappy = return . either error id . parseDecs
+
+happy :: QuasiQuoter
+happy = QuasiQuoter (happyToExp . parseHappyInfo) (error "happy: pattern quoting is not supported") 
+
+
+parseHappy :: String -> Happy
+parseHappy = fst . parseHappyInfo
+
+parseHappyInfo :: String -> (Happy,HappyInfo)
+parseHappyInfo s = (subst old "" $ code ++ "\n" ++ happyTemplate, info)
+  where
+    (code,info) = either error id $ runHappy [] s
+    old = unlines ["infixr 9 `HappyStk`",
+                     "data HappyStk a = HappyStk a (HappyStk a)"]
+
+happyWarn :: HappyInfo -> Q ()
+happyWarn i = do
+  loc <- location
+  let warnMsg msg = do
+      let (row,col)    = loc_start loc
+          (file)       = loc_filename loc
+      runIO $ hPutStrLn stderr $ file ++ ":"++show row++":"++show col++":"
+      runIO $ hPutStrLn stderr $ "    " ++ msg
+  when (sr i > 0) $ warnMsg $ show (sr i) ++ "Warning: shift/reduce conflicts"
+  when (rr i > 0) $ warnMsg $ show (rr i) ++ "Warning: reduce/reduce conflicts"
+
+
+happyToExp (code,info) = happyWarn info >> litE (StringL code)
+
+--	optIO (not (null unused_rules))
+--	   (hPutStrLn stderr ("unused rules: " ++ show (length unused_rules))) >>
+--	optIO (not (null unused_terminals))
+--	   (hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals))) >>
+
+
+-- This is some really bad code but it works for this purpose.
+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