hermit 0.3.0.0 → 0.3.1.0
raw patch · 5 files changed
+54/−1411 lines, 5 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ HERMIT.Optimize: getPhaseInfo :: OM PhaseInfo
+ HERMIT.Optimize: modifyCLS :: (CommandLineState -> CommandLineState) -> OM ()
- HERMIT.Optimize: at :: TranslateH Core LocalPathH -> OM a -> OM a
+ HERMIT.Optimize: at :: TranslateH CoreTC LocalPathH -> OM a -> OM a
- HERMIT.Optimize: run :: RewriteH Core -> OM ()
+ HERMIT.Optimize: run :: RewriteH CoreTC -> OM ()
Files
- dist/build/HERMIT/Parser.hs +0/−752
- dist/build/HERMIT/ParserCore.hs +0/−624
- hermit.cabal +5/−5
- src/HERMIT/Optimize.hs +38/−26
- src/HERMIT/Plugin.hs +11/−4
− dist/build/HERMIT/Parser.hs
@@ -1,752 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}-module HERMIT.Parser- ( Script- , parseScript- , unparseScript- , unparseExprH- , ExprH(..)- ) where--import Data.Char (isSpace)-import Data.List (intercalate)--import Control.Monad ((>=>))--import HERMIT.Syntax (isScriptInfixIdChar, isScriptIdFirstChar, isScriptIdChar)-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts---- parser produced by Happy Version 1.19.0--newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11 = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = Happy_GHC_Exts.Any-#else-type HappyAny = forall a . a-#endif-happyIn4 :: t4 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t4-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t5-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t6-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t7-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t8-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t9-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyIn10 :: t10 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t10-happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut10 #-}-happyIn11 :: t11 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t11-happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut11 #-}-happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x0e\x00\x1e\x00\x0e\x00\x06\x00\x00\x00\x00\x00\xfd\xff\x01\x00\x00\x00\x1a\x00\x0e\x00\x1a\x00\x0e\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x09\x00\x00\x00\x00\x00\x02\x00\x00\x00\x1a\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x45\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x4d\x00\x39\x00\x48\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x2d\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\xfa\xff\x00\x00\xfa\xff\x00\x00\xfc\xff\xfb\xff\xf9\xff\xf4\xff\xf2\xff\x00\x00\xfa\xff\xe8\xff\xfa\xff\x00\x00\xed\xff\xee\xff\xea\xff\xef\xff\xf1\xff\xf0\xff\xf6\xff\xe7\xff\x00\x00\xe9\xff\xfd\xff\x00\x00\xf3\xff\x00\x00\xfa\xff\xfa\xff\xfe\xff\xf7\xff\xf8\xff\xf5\xff\xeb\xff\xec\xff\x00\x00\xe6\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x04\x00\x01\x00\x05\x00\x02\x00\x08\x00\x05\x00\x03\x00\x04\x00\x05\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\x07\x00\x03\x00\x04\x00\x05\x00\x0e\x00\x06\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x03\x00\x04\x00\x05\x00\x05\x00\x07\x00\x03\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x03\x00\x04\x00\x05\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x1d\x00\x0a\x00\x1a\x00\x23\x00\x1e\x00\x0c\x00\x21\x00\x07\x00\x08\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1c\x00\x0a\x00\x24\x00\x03\x00\x0b\x00\x0c\x00\xff\xff\x25\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0a\x00\x15\x00\x07\x00\x08\x00\x0c\x00\x25\x00\x03\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1f\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x20\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x14\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x18\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x1e\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x15\x00\x07\x00\x08\x00\x16\x00\x17\x00\x19\x00\x07\x00\x08\x00\x00\x00\x12\x00\x13\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (1, 25) [- (1 , happyReduce_1),- (2 , happyReduce_2),- (3 , happyReduce_3),- (4 , happyReduce_4),- (5 , happyReduce_5),- (6 , happyReduce_6),- (7 , happyReduce_7),- (8 , happyReduce_8),- (9 , happyReduce_9),- (10 , happyReduce_10),- (11 , happyReduce_11),- (12 , happyReduce_12),- (13 , happyReduce_13),- (14 , happyReduce_14),- (15 , happyReduce_15),- (16 , happyReduce_16),- (17 , happyReduce_17),- (18 , happyReduce_18),- (19 , happyReduce_19),- (20 , happyReduce_20),- (21 , happyReduce_21),- (22 , happyReduce_22),- (23 , happyReduce_23),- (24 , happyReduce_24),- (25 , happyReduce_25)- ]--happy_n_terms = 15 :: Int-happy_n_nonterms = 8 :: Int--happyReduce_1 = happySpecReduce_2 0# happyReduction_1-happyReduction_1 happy_x_2- happy_x_1- = case happyOut4 happy_x_2 of { happy_var_2 -> - happyIn4- (CmdName "{" : happy_var_2- )}--happyReduce_2 = happySpecReduce_2 0# happyReduction_2-happyReduction_2 happy_x_2- happy_x_1- = case happyOut4 happy_x_2 of { happy_var_2 -> - happyIn4- (CmdName "}" : happy_var_2- )}--happyReduce_3 = happySpecReduce_1 0# happyReduction_3-happyReduction_3 happy_x_1- = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4- (happy_var_1- )}--happyReduce_4 = happySpecReduce_1 1# happyReduction_4-happyReduction_4 happy_x_1- = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn5- (happy_var_1- )}--happyReduce_5 = happySpecReduce_0 1# happyReduction_5-happyReduction_5 = happyIn5- ([]- )--happyReduce_6 = happySpecReduce_1 2# happyReduction_6-happyReduction_6 happy_x_1- = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn6- ([happy_var_1]- )}--happyReduce_7 = happySpecReduce_3 2# happyReduction_7-happyReduction_7 happy_x_3- happy_x_2- happy_x_1- = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut4 happy_x_3 of { happy_var_3 -> - happyIn6- ([happy_var_1, CmdName "}"] ++ happy_var_3- )}}--happyReduce_8 = happySpecReduce_3 2# happyReduction_8-happyReduction_8 happy_x_3- happy_x_2- happy_x_1- = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut4 happy_x_3 of { happy_var_3 -> - happyIn6- (happy_var_1 : happy_var_3- )}}--happyReduce_9 = happySpecReduce_2 2# happyReduction_9-happyReduction_9 happy_x_2- happy_x_1- = case happyOut4 happy_x_2 of { happy_var_2 -> - happyIn6- (happy_var_2- )}--happyReduce_10 = happySpecReduce_3 3# happyReduction_10-happyReduction_10 happy_x_3- happy_x_2- happy_x_1- = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> - case happyOut7 happy_x_3 of { happy_var_3 -> - happyIn7- (AppH (AppH (CmdName happy_var_2) happy_var_1) happy_var_3- )}}}--happyReduce_11 = happySpecReduce_1 3# happyReduction_11-happyReduction_11 happy_x_1- = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7- (happy_var_1- )}--happyReduce_12 = happySpecReduce_2 4# happyReduction_12-happyReduction_12 happy_x_2- happy_x_1- = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn8- (AppH happy_var_1 happy_var_2- )}}--happyReduce_13 = happySpecReduce_1 4# happyReduction_13-happyReduction_13 happy_x_1- = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn8- (happy_var_1- )}--happyReduce_14 = happySpecReduce_2 5# happyReduction_14-happyReduction_14 happy_x_2- happy_x_1- = case happyOutTok happy_x_2 of { (Ident happy_var_2) -> - happyIn9- (SrcName happy_var_2- )}--happyReduce_15 = happySpecReduce_2 5# happyReduction_15-happyReduction_15 happy_x_2- happy_x_1- = case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> - happyIn9- (SrcName happy_var_2- )}--happyReduce_16 = happySpecReduce_2 5# happyReduction_16-happyReduction_16 happy_x_2- happy_x_1- = case happyOutTok happy_x_2 of { (Quote happy_var_2) -> - happyIn9- (SrcName happy_var_2- )}--happyReduce_17 = happySpecReduce_1 5# happyReduction_17-happyReduction_17 happy_x_1- = case happyOutTok happy_x_1 of { (Quote happy_var_1) -> - happyIn9- (CmdName happy_var_1- )}--happyReduce_18 = happySpecReduce_1 5# happyReduction_18-happyReduction_18 happy_x_1- = case happyOutTok happy_x_1 of { (CoreString happy_var_1) -> - happyIn9- (CoreH happy_var_1- )}--happyReduce_19 = happySpecReduce_3 5# happyReduction_19-happyReduction_19 happy_x_3- happy_x_2- happy_x_1- = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn9- (ListH happy_var_2- )}--happyReduce_20 = happySpecReduce_3 5# happyReduction_20-happyReduction_20 happy_x_3- happy_x_2- happy_x_1- = case happyOut7 happy_x_2 of { happy_var_2 -> - happyIn9- (happy_var_2- )}--happyReduce_21 = happySpecReduce_1 5# happyReduction_21-happyReduction_21 happy_x_1- = case happyOutTok happy_x_1 of { (Ident happy_var_1) -> - happyIn9- (CmdName happy_var_1- )}--happyReduce_22 = happySpecReduce_1 6# happyReduction_22-happyReduction_22 happy_x_1- = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10- (happy_var_1- )}--happyReduce_23 = happySpecReduce_0 6# happyReduction_23-happyReduction_23 = happyIn10- ([]- )--happyReduce_24 = happySpecReduce_1 7# happyReduction_24-happyReduction_24 happy_x_1- = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn11- ([happy_var_1]- )}--happyReduce_25 = happySpecReduce_3 7# happyReduction_25-happyReduction_25 happy_x_3- happy_x_2- happy_x_1- = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut11 happy_x_3 of { happy_var_3 -> - happyIn11- (happy_var_1 : happy_var_3- )}}--happyNewToken action sts stk [] =- happyDoAction 14# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =- let cont i = happyDoAction i tk action sts stk tks in- case tk of {- ParenLeft -> cont 1#;- ParenRight -> cont 2#;- ScopeStart -> cont 3#;- ScopeEnd -> cont 4#;- ListStart -> cont 5#;- ListDelim -> cont 6#;- ListEnd -> cont 7#;- StmtEnd -> cont 8#;- Tick -> cont 9#;- CoreString happy_dollar_dollar -> cont 10#;- Quote happy_dollar_dollar -> cont 11#;- Ident happy_dollar_dollar -> cont 12#;- InfixOp happy_dollar_dollar -> cont 13#;- _ -> happyError' (tk:tks)- }--happyError_ 14# tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)--happyThen :: () => Either String a -> (a -> Either String b) -> Either String b-happyThen = (>>=)-happyReturn :: () => a -> Either String a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> Either String a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> Either String a-happyError' = parseError--parser tks = happySomeParser where- happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))--happySeq = happyDontSeq---parseError :: [Token] -> Either String a-parseError ts = Left $ "Parse error: " ++ show ts---- | A simple expression language AST, for things parsed from 'String' or JSON structures.-data ExprH- = SrcName String -- ^ Variable names (refers to source code).- | CmdName String -- ^ Commands (to be looked up in 'HERMIT.Dictionary').- | AppH ExprH ExprH -- ^ Application.- | CoreH String -- ^ Core Fragment- | ListH [ExprH] -- ^ List of expressions- deriving (Eq, Show)--data Token- = ParenLeft- | ParenRight- | ScopeStart- | ScopeEnd- | ListStart- | ListDelim- | ListEnd- | StmtEnd- | Tick- | CoreString String- | Quote String- | Ident String- | InfixOp String- deriving (Eq, Show)--lexError :: String -> Either String a-lexError msg = Left ("Lexer error: " ++ msg)--lexer :: String -> Either String [Token]-lexer [] = Right []-lexer ('\n':cs) = fmap (StmtEnd:) $ lexer cs-lexer (';' :cs) = fmap (StmtEnd:) $ lexer cs-lexer ('(' :cs) = fmap (ParenLeft:) $ lexer cs-lexer (')' :cs) = fmap (ParenRight:) $ lexer cs-lexer ('{' :cs) = fmap (ScopeStart:) $ lexer cs-lexer ('}' :cs) = fmap (ScopeEnd:) $ lexer cs-lexer ('\'':cs) = fmap (Tick:) $ lexer cs-lexer ('\"':cs) = do (str,cs') <- lexString cs- fmap (Quote str:) $ lexer cs'-lexer ('[':'|':cs) = do (str,cs') <- lexCore cs- fmap (CoreString str:) $ lexer cs'-lexer ('-':'-':cs) = let (_,s') = span (/= '\n') cs in lexer s'-lexer ('[' :cs) = fmap (ListStart:) $ lexer cs-lexer (',' :cs) = fmap (ListDelim:) $ lexer cs-lexer (']' :cs) = fmap (ListEnd:) $ lexer cs-lexer s@(c:cs) | isSpace c = lexer cs- | isScriptIdFirstChar c = let (i,s') = span isScriptIdChar s- in fmap (Ident i:) $ lexer s'- | isScriptInfixIdChar c = let (op,s') = span isScriptInfixIdChar s- in fmap (InfixOp op:) $ lexer s'-lexer s = lexError $ "no match on " ++ s--lexString :: String -> Either String (String,String)-lexString ('\"':cs) = Right ([],cs)-lexString ('\\':'\"':cs) = do (c',r) <- lexString cs- return ('"':c',r)-lexString (c:cs) = do (c',r) <- lexString cs- return (c:c',r)-lexString [] = lexError "no matching quote"--lexCore :: String -> Either String (String,String)-lexCore ('|':']':rest) = Right ([],rest)-lexCore (c:cs) = do (c',r) <- lexCore cs- return (c:c',r)-lexCore [] = lexError "no closing |]"--------------------------------------------------- | Use ghci Parser.hs to run this test function.-test = do- ln <- getLine- case ln of- "quit" -> return ()- _ -> do print $ lexer ln- print $ parseScript ln- test--type Script = [ExprH]--parseScript :: String -> Either String Script-parseScript = lexer >=> parser-------------------------------------------------unparseScript :: Script -> String-unparseScript = intercalate " ; " . map unparseExprH--unparseExprH :: ExprH -> String-unparseExprH (SrcName nm)- | nm /= "" && (all isScriptInfixIdChar nm || isScriptIdFirstChar (head nm) && all isScriptIdChar (tail nm)) = "'" ++ nm- | otherwise = "'\"" ++ concatMap escape nm ++ "\""- where escape '\"' = "\\\""- escape c = [c]-unparseExprH (CmdName nm)- | nm == "{" = "{ "- | nm == "}" = " }"- | all isScriptIdChar nm = nm- | otherwise = show nm -- with quotes-unparseExprH (AppH (AppH (CmdName nm) e1) e2)- | all isScriptInfixIdChar nm- = unparseAtom e1 ++ " " ++ nm ++ " " ++ unparseAtom e2-unparseExprH (AppH e1 e2) = unparseExprH e1 ++ " " ++ unparseAtom e2-unparseExprH (CoreH s) = "[|" ++ s ++ "|]"-unparseExprH (ListH es) = "[" ++ intercalate "," (map unparseExprH es) ++ "]"--unparseAtom :: ExprH -> String-unparseAtom e@(AppH {}) = "(" ++ unparseExprH e ++ ")"-unparseAtom e = unparseExprH e------------------------------------------------{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp --{-# LINE 13 "templates/GenericTemplate.hs" #-}------#if __GLASGOW_HASKELL__ > 706-#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool)-#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)-#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool)-#else-#define LT(n,m) (n Happy_GHC_Exts.<# m)-#define GTE(n,m) (n Happy_GHC_Exts.>=# m)-#define EQ(n,m) (n Happy_GHC_Exts.==# m)-#endif-{-# LINE 45 "templates/GenericTemplate.hs" #-}---data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList------{-# LINE 66 "templates/GenericTemplate.hs" #-}--{-# LINE 76 "templates/GenericTemplate.hs" #-}--{-# LINE 85 "templates/GenericTemplate.hs" #-}--infixr 9 `HappyStk`-data HappyStk a = HappyStk a (HappyStk a)---------------------------------------------------------------------------------- starting the parse--happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll---------------------------------------------------------------------------------- Accepting the parse---- If the current token is 0#, it means we've just accepted a partial--- parse (a %partial parser). We must ignore the saved token on the top of--- the stack in this case.-happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =- happyReturn1 ans-happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans)---------------------------------------------------------------------------------- Arrays only: do the next action----happyDoAction i tk st- = {- nothing -}--- case action of- 0# -> {- nothing -}- happyFail i tk st- -1# -> {- nothing -}- happyAccept i tk st- n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}-- (happyReduceArr Happy_Data_Array.! rule) i tk st- where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))- n -> {- nothing -}--- happyShift new_state i tk st- where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))- where off = indexShortOffAddr happyActOffsets st- off_i = (off Happy_GHC_Exts.+# i)- check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))- then EQ(indexShortOffAddr happyCheck off_i, i)- else False- action- | check = indexShortOffAddr happyTable off_i- | otherwise = indexShortOffAddr happyDefActions st---indexShortOffAddr (HappyA# arr) off =- Happy_GHC_Exts.narrow16Int# i- where- i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)- high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))- low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))- off' = off Happy_GHC_Exts.*# 2#------data HappyAddr = HappyA# Happy_GHC_Exts.Addr#------------------------------------------------------------------------------------- HappyState data type (not arrays)--{-# LINE 169 "templates/GenericTemplate.hs" #-}---------------------------------------------------------------------------------- Shifting a token--happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =- let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in--- trace "shifting the error token" $- happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)--happyShift new_state i tk st sts stk =- happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)---- happyReduce is specialised for the common cases.--happySpecReduce_0 i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happySpecReduce_0 nt fn j tk st@((action)) sts stk- = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)--happySpecReduce_1 i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')- = let r = fn v1 in- happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_2 i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')- = let r = fn v1 v2 in- happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_3 i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')- = let r = fn v1 v2 v3 in- happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happyReduce k i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happyReduce k nt fn j tk st sts stk- = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of- sts1@((HappyCons (st1@(action)) (_))) ->- let r = fn stk in -- it doesn't hurt to always seq here...- happyDoSeq r (happyGoto nt j tk st1 sts1 r)--happyMonadReduce k nt fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happyMonadReduce k nt fn j tk st sts stk =- case happyDrop k (HappyCons (st) (sts)) of- sts1@((HappyCons (st1@(action)) (_))) ->- let drop_stk = happyDropStk k stk in- happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))--happyMonad2Reduce k nt fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happyMonad2Reduce k nt fn j tk st sts stk =- case happyDrop k (HappyCons (st) (sts)) of- sts1@((HappyCons (st1@(action)) (_))) ->- let drop_stk = happyDropStk k stk-- off = indexShortOffAddr happyGotoOffsets st1- off_i = (off Happy_GHC_Exts.+# nt)- new_state = indexShortOffAddr happyTable off_i---- in- happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))--happyDrop 0# l = l-happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t--happyDropStk 0# l = l-happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs---------------------------------------------------------------------------------- Moving to a new state after a reduction---happyGoto nt j tk st = - {- nothing -}- happyDoAction j tk new_state- where off = indexShortOffAddr happyGotoOffsets st- off_i = (off Happy_GHC_Exts.+# nt)- new_state = indexShortOffAddr happyTable off_i------------------------------------------------------------------------------------- Error recovery (0# is the error token)---- parse error if we are in recovery and we fail again-happyFail 0# tk old_st _ stk@(x `HappyStk` _) =- let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in--- trace "failing" $ - happyError_ i tk--{- We don't need state discarding for our restricted implementation of- "error". In fact, it can cause some bogus parses, so I've disabled it- for now --SDM---- discard a state-happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) =--- trace ("discarding state, depth " ++ show (length stk)) $- happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))--}---- Enter error recovery: generate an error token,--- save the old token and carry on.-happyFail i tk (action) sts stk =--- trace "entering error recovery" $- happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)---- Internal happy errors:--notHappyAtAll :: a-notHappyAtAll = error "Internal Happy error\n"---------------------------------------------------------------------------------- Hack to get the typechecker to accept our action functions---happyTcHack :: Happy_GHC_Exts.Int# -> a -> a-happyTcHack x y = y-{-# INLINE happyTcHack #-}----------------------------------------------------------------------------------- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq--- otherwise it emits--- happySeq = happyDontSeq--happyDoSeq, happyDontSeq :: a -> b -> b-happyDoSeq a b = a `seq` b-happyDontSeq a b = b---------------------------------------------------------------------------------- Don't inline any functions from the template. GHC has a nasty habit--- of deciding to inline happyGoto everywhere, which increases the size of--- the generated parser quite a bit.---{-# NOINLINE happyDoAction #-}-{-# NOINLINE happyTable #-}-{-# NOINLINE happyCheck #-}-{-# NOINLINE happyActOffsets #-}-{-# NOINLINE happyGotoOffsets #-}-{-# NOINLINE happyDefActions #-}--{-# NOINLINE happyShift #-}-{-# NOINLINE happySpecReduce_0 #-}-{-# NOINLINE happySpecReduce_1 #-}-{-# NOINLINE happySpecReduce_2 #-}-{-# NOINLINE happySpecReduce_3 #-}-{-# NOINLINE happyReduce #-}-{-# NOINLINE happyMonadReduce #-}-{-# NOINLINE happyGoto #-}-{-# NOINLINE happyFail #-}---- end of Happy Template.
− dist/build/HERMIT/ParserCore.hs
@@ -1,624 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}-{-# LANGUAGE CPP #-}- module HERMIT.ParserCore (parseCore, parseCoreExprT, parse2beforeBiR, parse3beforeBiR) where--import Control.Arrow-import Control.Monad.Reader-import Data.Char (isSpace, isDigit)--import HERMIT.Context-import HERMIT.External-import HERMIT.GHC-import HERMIT.Kure-import HERMIT.Monad-import HERMIT.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar)--import HERMIT.Dictionary.Common--import Language.KURE.MonadCatch (prefixFailMsg)--import Language.Haskell.TH as TH-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts---- parser produced by Happy Version 1.19.0--newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = Happy_GHC_Exts.Any-#else-type HappyAny = forall a . a-#endif-happyIn4 :: t4 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t4-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t5-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t6-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t7-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t8-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t9-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\xf8\xff\xf8\xff\xf8\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\xf0\xff\xf6\xff\x00\x00\x00\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x0b\x00\x18\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\xfc\xff\xf8\xff\xf7\xff\xf9\xff\x00\x00\xf4\xff\xf6\xff\xf5\xff\x00\x00\x00\x00\xfa\xff\xfd\xff\xfb\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x0c\x00\x0d\x00\x0d\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x1c\x00\x22\x00\x1e\x00\x1c\x00\x20\x00\x1e\x00\xff\xff\x20\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x02\x00\x03\x00\x04\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x08\x00\x0e\x00\x10\x00\x08\x00\x0c\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x09\x00\xff\xff\x0a\x00\x09\x00\x0b\x00\x0a\x00\x00\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0e\x00\x04\x00\x05\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (1, 11) [- (1 , happyReduce_1),- (2 , happyReduce_2),- (3 , happyReduce_3),- (4 , happyReduce_4),- (5 , happyReduce_5),- (6 , happyReduce_6),- (7 , happyReduce_7),- (8 , happyReduce_8),- (9 , happyReduce_9),- (10 , happyReduce_10),- (11 , happyReduce_11)- ]--happy_n_terms = 35 :: Int-happy_n_nonterms = 6 :: Int--happyReduce_1 = happySpecReduce_1 0# happyReduction_1-happyReduction_1 happy_x_1- = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4- (happy_var_1- )}--happyReduce_2 = happySpecReduce_2 1# happyReduction_2-happyReduction_2 happy_x_2- happy_x_1- = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn5- (App happy_var_1 happy_var_2- )}}--happyReduce_3 = happySpecReduce_1 1# happyReduction_3-happyReduction_3 happy_x_1- = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn5- (happy_var_1- )}--happyReduce_4 = happySpecReduce_3 2# happyReduction_4-happyReduction_4 happy_x_3- happy_x_2- happy_x_1- = case happyOut4 happy_x_2 of { happy_var_2 -> - happyIn6- (happy_var_2- )}--happyReduce_5 = happyMonadReduce 2# 2# happyReduction_5-happyReduction_5 (happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest) tk- = happyThen (( lookupName "()" Var)- ) (\r -> happyReturn (happyIn6 r))--happyReduce_6 = happySpecReduce_1 2# happyReduction_6-happyReduction_6 happy_x_1- = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn6- (happy_var_1- )}--happyReduce_7 = happySpecReduce_1 2# happyReduction_7-happyReduction_7 happy_x_1- = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn6- (happy_var_1- )}--happyReduce_8 = happySpecReduce_1 2# happyReduction_8-happyReduction_8 happy_x_1- = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn6- (happy_var_1- )}--happyReduce_9 = happyMonadReduce 1# 3# happyReduction_9-happyReduction_9 (happy_x_1 `HappyStk`- happyRest) tk- = happyThen (case happyOutTok happy_x_1 of { (Tinteger happy_var_1) -> - ( mkIntExpr' happy_var_1)}- ) (\r -> happyReturn (happyIn7 r))--happyReduce_10 = happyMonadReduce 1# 4# happyReduction_10-happyReduction_10 (happy_x_1 `HappyStk`- happyRest) tk- = happyThen (case happyOutTok happy_x_1 of { (Tstring happy_var_1) -> - ( lift $ mkStringExpr happy_var_1)}- ) (\r -> happyReturn (happyIn8 r))--happyReduce_11 = happyMonadReduce 1# 5# happyReduction_11-happyReduction_11 (happy_x_1 `HappyStk`- happyRest) tk- = happyThen (case happyOutTok happy_x_1 of { (Tname happy_var_1) -> - ( lookupName happy_var_1 varToCoreExpr)}- ) (\r -> happyReturn (happyIn9 r))--happyNewToken action sts stk [] =- happyDoAction 34# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =- let cont i = happyDoAction i tk action sts stk tks in- case tk of {- Tforall -> cont 1#;- Trec -> cont 2#;- Tlet -> cont 3#;- Tin -> cont 4#;- Tcase -> cont 5#;- Tof -> cont 6#;- Tcast -> cont 7#;- Tnote -> cont 8#;- Texternal -> cont 9#;- Tlocal -> cont 10#;- Twild -> cont 11#;- Toparen -> cont 12#;- Tcparen -> cont 13#;- Tobrace -> cont 14#;- Tcbrace -> cont 15#;- Thash -> cont 16#;- Teq -> cont 17#;- Tcolon -> cont 18#;- Tcoloncolon -> cont 19#;- Tcoloneqcolon -> cont 20#;- Tstar -> cont 21#;- Tarrow -> cont 22#;- Tlambda -> cont 23#;- Tat -> cont 24#;- Tdot -> cont 25#;- Tquestion -> cont 26#;- Tsemicolon -> cont 27#;- Tname happy_dollar_dollar -> cont 28#;- Tcname happy_dollar_dollar -> cont 29#;- Tinteger happy_dollar_dollar -> cont 30#;- Trational happy_dollar_dollar -> cont 31#;- Tstring happy_dollar_dollar -> cont 32#;- Tchar happy_dollar_dollar -> cont 33#;- _ -> happyError' (tk:tks)- }--happyError_ 34# tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)--happyThen :: () => CoreParseM a -> (a -> CoreParseM b) -> CoreParseM b-happyThen = (>>=)-happyReturn :: () => a -> CoreParseM a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> CoreParseM a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> CoreParseM a-happyError' = parseError--parser tks = happySomeParser where- happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))--happySeq = happyDontSeq---mkIntExpr' :: Integer -> CoreParseM CoreExpr-#if __GLASGOW_HASKELL__ > 706-mkIntExpr' i = do- dflags <- lift getDynFlags- return $ mkIntExpr dflags i-#else-mkIntExpr' i = return $ mkIntExpr i-#endif--lookupName :: String -> (Id -> CoreExpr) -> CoreParseM CoreExpr-lookupName nm k = do- c <- ask- v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId (TH.mkName nm) c- return (k v)--type CoreParseM a = ReaderT HermitC HermitM a--parseError :: Monad m => [Token] -> m a-parseError ts = fail $ "core parse error: " ++ show ts--data Token- = Tforall- | Trec- | Tlet- | Tin- | Tcase- | Tof- | Tcast- | Tnote- | Texternal- | Tlocal- | Twild --- | Toparen --- | Tcparen --- | Tobrace- | Tcbrace- | Thash- | Teq- | Tcolon --- | Tcoloncolon --- | Tcoloneqcolon- | Tstar- | Tarrow- | Tlambda --- | Tat- | Tdot- | Tquestion- | Tsemicolon- | Tname String- | Tcname String- | Tinteger Integer- | Trational Float- | Tstring String- | Tchar Char- deriving (Eq, Show)--lexer :: String -> Either String [Token]-lexer [] = Right []-lexer ('_' :cs) = fmap (Twild:) $ lexer cs-lexer ('(' :cs) = fmap (Toparen:) $ lexer cs-lexer (')' :cs) = fmap (Tcparen:) $ lexer cs-lexer (':':':':cs) = fmap (Tcoloncolon:) $ lexer cs--- lexer (':' :cs) = fmap (Tcolon:) $ lexer cs-lexer ('\\':cs) = fmap (Tlambda:) $ lexer cs-lexer ('-':'>':cs) = fmap (Tarrow:) $ lexer cs-lexer ('\"':cs) = let (str,rest) = span (/='\"') cs- in case rest of- ('\"':cs') -> fmap (Tstring str:) $ lexer cs'- _ -> Left "lexer: no matching quote"-lexer s@(c:cs) | isSpace c = lexer cs- | isDigit c = let (i,s') = span isDigit s- in fmap (Tinteger (read i):) $ lexer s'- | isCoreIdFirstChar c = let (i,s') = span isCoreIdChar s- in fmap (Tname i:) $ lexer s'- | isCoreInfixIdChar c = let (op,s') = span isCoreInfixIdChar s- in fmap (Tname op:) $ lexer s'-lexer s = Left $ "lexer: no match on " ++ s-------------------------------------------------parseCore :: CoreString -> HermitC -> HermitM CoreExpr-parseCore (CoreString s) c =- case lexer s of- Left msg -> fail msg- Right tokens -> runReaderT (parser tokens) c--------------------------------------------------- These three should probably go somewhere else.---- | Parse a 'CoreString' to a 'CoreExpr', using the current context.-parseCoreExprT :: CoreString -> TranslateH a CoreExpr-parseCoreExprT = contextonlyT . parseCore--parse2beforeBiR :: (CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> BiRewriteH a-parse2beforeBiR f s1 s2 = beforeBiR (parseCoreExprT s1 &&& parseCoreExprT s2) (uncurry f)--parse3beforeBiR :: (CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> CoreString -> BiRewriteH a-parse3beforeBiR f s1 s2 s3 = beforeBiR ((parseCoreExprT s1 &&& parseCoreExprT s2) &&& parseCoreExprT s3) ((uncurry.uncurry) f)------------------------------------------------{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp --{-# LINE 13 "templates/GenericTemplate.hs" #-}------#if __GLASGOW_HASKELL__ > 706-#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool)-#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)-#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool)-#else-#define LT(n,m) (n Happy_GHC_Exts.<# m)-#define GTE(n,m) (n Happy_GHC_Exts.>=# m)-#define EQ(n,m) (n Happy_GHC_Exts.==# m)-#endif-{-# LINE 45 "templates/GenericTemplate.hs" #-}---data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList------{-# LINE 66 "templates/GenericTemplate.hs" #-}--{-# LINE 76 "templates/GenericTemplate.hs" #-}--{-# LINE 85 "templates/GenericTemplate.hs" #-}--infixr 9 `HappyStk`-data HappyStk a = HappyStk a (HappyStk a)---------------------------------------------------------------------------------- starting the parse--happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll---------------------------------------------------------------------------------- Accepting the parse---- If the current token is 0#, it means we've just accepted a partial--- parse (a %partial parser). We must ignore the saved token on the top of--- the stack in this case.-happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =- happyReturn1 ans-happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans)---------------------------------------------------------------------------------- Arrays only: do the next action----happyDoAction i tk st- = {- nothing -}--- case action of- 0# -> {- nothing -}- happyFail i tk st- -1# -> {- nothing -}- happyAccept i tk st- n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}-- (happyReduceArr Happy_Data_Array.! rule) i tk st- where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))- n -> {- nothing -}--- happyShift new_state i tk st- where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))- where off = indexShortOffAddr happyActOffsets st- off_i = (off Happy_GHC_Exts.+# i)- check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))- then EQ(indexShortOffAddr happyCheck off_i, i)- else False- action- | check = indexShortOffAddr happyTable off_i- | otherwise = indexShortOffAddr happyDefActions st---indexShortOffAddr (HappyA# arr) off =- Happy_GHC_Exts.narrow16Int# i- where- i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)- high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))- low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))- off' = off Happy_GHC_Exts.*# 2#------data HappyAddr = HappyA# Happy_GHC_Exts.Addr#------------------------------------------------------------------------------------- HappyState data type (not arrays)--{-# LINE 169 "templates/GenericTemplate.hs" #-}---------------------------------------------------------------------------------- Shifting a token--happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =- let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in--- trace "shifting the error token" $- happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)--happyShift new_state i tk st sts stk =- happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)---- happyReduce is specialised for the common cases.--happySpecReduce_0 i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happySpecReduce_0 nt fn j tk st@((action)) sts stk- = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)--happySpecReduce_1 i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')- = let r = fn v1 in- happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_2 i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')- = let r = fn v1 v2 in- happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_3 i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')- = let r = fn v1 v2 v3 in- happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happyReduce k i fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happyReduce k nt fn j tk st sts stk- = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of- sts1@((HappyCons (st1@(action)) (_))) ->- let r = fn stk in -- it doesn't hurt to always seq here...- happyDoSeq r (happyGoto nt j tk st1 sts1 r)--happyMonadReduce k nt fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happyMonadReduce k nt fn j tk st sts stk =- case happyDrop k (HappyCons (st) (sts)) of- sts1@((HappyCons (st1@(action)) (_))) ->- let drop_stk = happyDropStk k stk in- happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))--happyMonad2Reduce k nt fn 0# tk st sts stk- = happyFail 0# tk st sts stk-happyMonad2Reduce k nt fn j tk st sts stk =- case happyDrop k (HappyCons (st) (sts)) of- sts1@((HappyCons (st1@(action)) (_))) ->- let drop_stk = happyDropStk k stk-- off = indexShortOffAddr happyGotoOffsets st1- off_i = (off Happy_GHC_Exts.+# nt)- new_state = indexShortOffAddr happyTable off_i---- in- happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))--happyDrop 0# l = l-happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t--happyDropStk 0# l = l-happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs---------------------------------------------------------------------------------- Moving to a new state after a reduction---happyGoto nt j tk st = - {- nothing -}- happyDoAction j tk new_state- where off = indexShortOffAddr happyGotoOffsets st- off_i = (off Happy_GHC_Exts.+# nt)- new_state = indexShortOffAddr happyTable off_i------------------------------------------------------------------------------------- Error recovery (0# is the error token)---- parse error if we are in recovery and we fail again-happyFail 0# tk old_st _ stk@(x `HappyStk` _) =- let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in--- trace "failing" $ - happyError_ i tk--{- We don't need state discarding for our restricted implementation of- "error". In fact, it can cause some bogus parses, so I've disabled it- for now --SDM---- discard a state-happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) =--- trace ("discarding state, depth " ++ show (length stk)) $- happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))--}---- Enter error recovery: generate an error token,--- save the old token and carry on.-happyFail i tk (action) sts stk =--- trace "entering error recovery" $- happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)---- Internal happy errors:--notHappyAtAll :: a-notHappyAtAll = error "Internal Happy error\n"---------------------------------------------------------------------------------- Hack to get the typechecker to accept our action functions---happyTcHack :: Happy_GHC_Exts.Int# -> a -> a-happyTcHack x y = y-{-# INLINE happyTcHack #-}----------------------------------------------------------------------------------- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq--- otherwise it emits--- happySeq = happyDontSeq--happyDoSeq, happyDontSeq :: a -> b -> b-happyDoSeq a b = a `seq` b-happyDontSeq a b = b---------------------------------------------------------------------------------- Don't inline any functions from the template. GHC has a nasty habit--- of deciding to inline happyGoto everywhere, which increases the size of--- the generated parser quite a bit.---{-# NOINLINE happyDoAction #-}-{-# NOINLINE happyTable #-}-{-# NOINLINE happyCheck #-}-{-# NOINLINE happyActOffsets #-}-{-# NOINLINE happyGotoOffsets #-}-{-# NOINLINE happyDefActions #-}--{-# NOINLINE happyShift #-}-{-# NOINLINE happySpecReduce_0 #-}-{-# NOINLINE happySpecReduce_1 #-}-{-# NOINLINE happySpecReduce_2 #-}-{-# NOINLINE happySpecReduce_3 #-}-{-# NOINLINE happyReduce #-}-{-# NOINLINE happyMonadReduce #-}-{-# NOINLINE happyGoto #-}-{-# NOINLINE happyFail #-}---- end of Happy Template.
hermit.cabal view
@@ -1,5 +1,5 @@ Name: hermit-Version: 0.3.0.0+Version: 0.3.1.0 Synopsis: Haskell Equational Reasoning Model-to-Implementation Tunnel Description: HERMIT uses Haskell to express semi-formal models,@@ -30,12 +30,12 @@ . @ $ hermit Reverse.hs Reverse.hss resume- [starting HERMIT v0.3.0.0 on Reverse.hs]+ [starting HERMIT v0.3.1.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main:Reverse.hss -fplugin-opt=HERMIT:Main:resume [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ...- Loading package hermit-0.3.0.0 ... linking ... done.+ Loading package hermit-0.3.1.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) Linking Reverse ... $ ./Reverse@@ -46,12 +46,12 @@ . @ $ hermit Reverse.hs- [starting HERMIT v0.3.0.0 on Reverse.hs]+ [starting HERMIT v0.3.1.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main: [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ...- Loading package hermit-0.3.0.0 ... linking ... done.+ Loading package hermit-0.3.1.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) ===================== Welcome to HERMIT ===================== HERMIT is a toolkit for the interactive transformation of GHC
src/HERMIT/Optimize.hs view
@@ -18,6 +18,9 @@ , allPhases , firstPhase , lastPhase+ -- ** Knobs and Dials+ , getPhaseInfo+ , modifyCLS -- ** Types , OM , omToIO@@ -28,6 +31,7 @@ import Control.Monad.Error hiding (guard) import Control.Monad.Operational import Control.Monad.State hiding (guard)+import Control.Monad.Reader hiding (guard) import Data.Default import Data.Monoid@@ -56,7 +60,7 @@ RR :: (Injection ModGuts g, Walker HermitC g) => RewriteH g -> OInst () Query :: (Injection ModGuts g, Walker HermitC g) => TranslateH g a -> OInst a -newtype OM a = OM (ProgramT OInst (CLM IO) a)+newtype OM a = OM (ProgramT OInst (ReaderT PhaseInfo (CLM IO)) a) deriving (Monad, MonadIO) optimize :: ([CommandLineOption] -> OM ()) -> Plugin@@ -96,33 +100,35 @@ -- TODO - better name! omToIO :: CommandLineState -> PhaseInfo -> OM a -> IO (Either CLException a, CommandLineState)-omToIO initState phaseInfo (OM opt) = runCLM initState (eval phaseInfo opt)+omToIO initState phaseInfo (OM opt) = runCLM initState (runReaderT (eval opt) phaseInfo) -eval :: PhaseInfo -> ProgramT OInst (CLM IO) a -> CLM IO a-eval phaseInfo comp = do+eval :: ProgramT OInst (ReaderT PhaseInfo (CLM IO)) a -> ReaderT PhaseInfo (CLM IO) a+eval comp = do (kernel, env) <- gets $ cl_kernel &&& cl_kernel_env v <- viewT comp case v of Return x -> return x- RR rr :>>= k -> runS (applyS kernel rr env) >>= eval phaseInfo . k- Query tr :>>= k -> runK (queryS kernel tr env) >>= eval phaseInfo . k+ RR rr :>>= k -> lift (runS (applyS kernel rr env)) >>= eval . k+ Query tr :>>= k -> lift (runK (queryS kernel tr env)) >>= eval . k Shell es os :>>= k -> do- -- We want to discard the current focus, open the shell at- -- the top level, then restore the current focus.- paths <- resetScoping env- catchContinue (commandLine os defaultBehavior es)- _ <- resetScoping env- restoreScoping env paths- eval phaseInfo $ k ()- Guard p (OM m) :>>= k -> when (p phaseInfo) (eval phaseInfo m) >>= eval phaseInfo . k+ lift $ do+ -- We want to discard the current focus, open the shell at+ -- the top level, then restore the current focus.+ paths <- resetScoping env+ catchContinue (commandLine os defaultBehavior es)+ _ <- resetScoping env+ restoreScoping env paths+ eval $ k ()+ Guard p (OM m) :>>= k -> ask >>= \ phaseInfo -> when (p phaseInfo) (eval m) >>= eval . k Focus tp (OM m) :>>= k -> do- sast <- gets cl_cursor- p <- queryS kernel tp env sast -- run the pathfinding translation- runS $ beginScopeS kernel -- remember the current path- runS $ modPathS kernel (<> p) env -- modify the current path- r <- eval phaseInfo m -- run the focused computation- runS $ endScopeS kernel -- endscope on it, so we go back to where we started- eval phaseInfo $ k r+ lift $ do+ sast <- gets cl_cursor+ p <- queryS kernel tp env sast -- run the pathfinding translation+ runS $ beginScopeS kernel -- remember the current path+ runS $ modPathS kernel (<> p) env -- modify the current path+ r <- eval m -- run the focused computation+ lift $ runS $ endScopeS kernel -- endscope on it, so we go back to where we started+ eval $ k r ------------------------- Shell-related helpers -------------------------------------- @@ -166,7 +172,7 @@ interactive :: [External] -> [CommandLineOption] -> OM () interactive es os = OM . singleton $ Shell (externals ++ es) os -run :: RewriteH Core -> OM ()+run :: RewriteH CoreTC -> OM () run = OM . singleton . RR query :: (Injection GHC.ModGuts g, Walker HermitC g) => TranslateH g a -> OM a@@ -177,7 +183,7 @@ guard :: (PhaseInfo -> Bool) -> OM () -> OM () guard p = OM . singleton . Guard p -at :: TranslateH Core LocalPathH -> OM a -> OM a+at :: TranslateH CoreTC LocalPathH -> OM a -> OM a at tp = OM . singleton . Focus tp phase :: Int -> OM () -> OM ()@@ -204,11 +210,17 @@ ----------------------------- other ------------------------------ +getPhaseInfo :: OM PhaseInfo+getPhaseInfo = OM $ lift ask+ display :: OM ()-display = OM $ lift $ performQuery Display+display = OM $ lift $ lift $ performQuery Display +modifyCLS :: (CommandLineState -> CommandLineState) -> OM ()+modifyCLS = OM . modify+ setPretty :: PrettyH CoreTC -> OM ()-setPretty pp = OM $ modify $ \s -> s { cl_pretty = pp }+setPretty pp = modifyCLS $ \s -> s { cl_pretty = pp } setPrettyOptions :: PrettyOptions -> OM ()-setPrettyOptions po = OM $ modify $ \s -> s { cl_pretty_opts = po }+setPrettyOptions po = modifyCLS $ \s -> s { cl_pretty_opts = po }
src/HERMIT/Plugin.hs view
@@ -26,11 +26,12 @@ -- This is a bit of a hack; otherwise we lose what we've not seen liftIO $ hSetBuffering stdout NoBuffering-- let passes = map getCorePass todos+ + let todos' = flattenTodos todos+ passes = map getCorePass todos' allPasses = foldr (\ (n,p,seen,notyet) r -> mkPass n seen notyet : p : r)- [mkPass (length todos) passes []]- (zip4 [0..] todos (inits passes) (tails passes))+ [mkPass (length todos') passes []]+ (zip4 [0..] todos' (inits passes) (tails passes)) mkPass n ps ps' = CoreDoPluginPass ("HERMIT" ++ show n) $ modFilter hp (PhaseInfo n ps ps') opts return allPasses@@ -119,6 +120,12 @@ getCorePass (CoreDoPluginPass nm _) = PluginPass nm getCorePass CoreDoNothing = NoOp -- getCorePass _ = Unknown++flattenTodos :: [CoreToDo] -> [CoreToDo]+flattenTodos = concatMap f+ where f (CoreDoPasses ps) = flattenTodos ps+ f CoreDoNothing = []+ f other = [other] data PhaseInfo = PhaseInfo { phaseNum :: Int