core 0.2 → 0.3

raw patch · 5 files changed

+411/−13 lines, 5 filesdep +arrayPVP ok

version bump matches the API change (PVP)

Dependencies added: array

API changes (from Hackage documentation)

Files

• core.cabal +4/−2
• dist/build/Language/Core/Happy.hs +364/−0
• src/Language/Core/Happy.y +23/−0
• src/Language/Core/Parser.hs +9/−0
• src/Language/Core/Syntax.lhs +11/−11

@@ -1,5 +1,5 @@ name:                core-version:             0.2+version:             0.3 synopsis:            External core parser and pretty printer. description:         External core parser and pretty printer. category:            Language@@ -7,11 +7,13 @@ license-file:        LICENSE author:              David Himmelstrup maintainer:          lemmih@gmail.com-build-Depends:       base, parsec, bytestring, pretty+build-Depends:       base, parsec, bytestring, pretty, array ghc-options:         +ghc-prof-options:    -auto-all build-type:          Simple hs-source-dirs:      src exposed-modules:     Language.Core                      Language.Core.Syntax                      Language.Core.Parser                      Language.Core.Pretty+                     Language.Core.Happy

@@ -0,0 +1,364 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+module Language.Core.Happy where++import Language.Core.Parser (Pos, Token, lexer)+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+#else+import Array+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif++-- parser produced by Happy Version 1.17++newtype HappyAbsSyn t4 = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = GHC.Exts.Any+#else+type HappyAny = forall a . a+#endif+happyIn4 :: t4 -> (HappyAbsSyn t4)+happyIn4 x = unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn t4) -> t4+happyOut4 x = unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyInTok :: Token -> (HappyAbsSyn t4)+happyInTok x = unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn t4) -> Token+happyOutTok x = unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x00\x00\x00\x00\x02\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x01\x00\x00\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x00\x00\xff\xff\x01\x00"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x02\x00\x00\x00\xff\xff"#++happyReduceArr = array (1, 1) [+	(1 , happyReduce_1)+	]++happy_n_terms = 2 :: Int+happy_n_nonterms = 1 :: Int++happyReduce_1 = happySpecReduce_0  0# happyReduction_1+happyReduction_1  =  happyIn4+		 (undefined+	)++happyNewToken action sts stk [] =+	happyDoAction 1# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+	let cont i = happyDoAction i tk action sts stk tks in+	case tk of {+	_ -> happyError' (tk:tks)+	}++happyError_ tk tks = happyError' (tk:tks)++newtype HappyIdentity a = HappyIdentity a+happyIdentity = HappyIdentity+happyRunIdentity (HappyIdentity a) = a++instance Monad HappyIdentity where+    return = HappyIdentity+    (HappyIdentity p) >>= q = q p++happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b+happyThen = (>>=)+happyReturn :: () => a -> HappyIdentity a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> HappyIdentity a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [Token] -> HappyIdentity a+happyError' = HappyIdentity . parseError++parseModule tks = happyRunIdentity happySomeParser where+  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++parseError _ = error "parse error"+{-# 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 28 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Int# Happy_IntList++++++{-# LINE 49 "templates/GenericTemplate.hs" #-}++{-# LINE 59 "templates/GenericTemplate.hs" #-}++{-# LINE 68 "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 | (n <# (0# :: Int#)) -> {- nothing -}++				     (happyReduceArr ! rule) i tk st+				     where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))+		n		  -> {- nothing -}+++				     happyShift new_state i tk st+				     where new_state = (n -# (1# :: Int#))+   where off    = indexShortOffAddr happyActOffsets st+	 off_i  = (off +# i)+	 check  = if (off_i >=# (0# :: Int#))+			then (indexShortOffAddr happyCheck off_i ==#  i)+			else False+ 	 action | check     = indexShortOffAddr happyTable off_i+		| otherwise = indexShortOffAddr happyDefActions st++{-# LINE 127 "templates/GenericTemplate.hs" #-}+++indexShortOffAddr (HappyA# arr) off =+#if __GLASGOW_HASKELL__ > 500+	narrow16Int# i+#elif __GLASGOW_HASKELL__ == 500+	intToInt16# i+#else+	(i `iShiftL#` 16#) `iShiftRA#` 16#+#endif+  where+#if __GLASGOW_HASKELL__ >= 503+	i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+#else+	i = word2Int# ((high `shiftL#` 8#) `or#` low)+#endif+	high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+	low  = int2Word# (ord# (indexCharOffAddr# arr off'))+	off' = off *# 2#++++++data HappyAddr = HappyA# Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 170 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+     let i = (case unsafeCoerce# x of { (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 -# (1# :: 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 =+        happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))+       where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))+             drop_stk = happyDropStk k 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 =+       happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))+       where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))+             drop_stk = happyDropStk k stk++             off    = indexShortOffAddr happyGotoOffsets st1+             off_i  = (off +# nt)+             new_state = indexShortOffAddr happyTable off_i+++++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::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 +# 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 =+--	trace "failing" $ +    	happyError_ 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 ( (unsafeCoerce# (I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: 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.

@@ -0,0 +1,23 @@+{+module Language.Core.Happy where++import Language.Core.Parser (Pos, Token, lexer)++}++%name parseModule+%tokentype { Token }+%error { parseError }+++%%++Module :                  { undefined }++{++parseError _ = error "parse error"+++}+

@@ -1,6 +1,9 @@ {-# LANGUAGE NoMonomorphismRestriction, PatternGuards #-} module Language.Core.Parser     ( parseModule+    , Pos(..)+    , Token(..)+    , lexer     ) where  import Data.Char@@ -363,6 +366,12 @@                          matchToken Arrow                          k <- kind                          return (Karrow atomic k)+              , try $ do a <- parens ty+                         matchToken Colon+                         matchToken Equal+                         matchToken Colon+                         b <- parens ty+                         return $ Keq a b               , akind ]  tyvar = lname

@@ -8,22 +8,22 @@  data Module  = Module (Pkgname, Mname) [Tdef] [Vdefg]-   deriving (Show,Eq)+   deriving (Show,Read,Eq)  data Tdef    = Data (Qual Tcon) [Tbind] [Cdef]   | Newtype (Qual Tcon) (Qual Tcon) [Tbind] Ty-   deriving (Show,Eq)+   deriving (Show,Read,Eq)  data Cdef    = Constr (Qual Dcon) [Tbind] [Ty]   | GadtConstr (Qual Dcon) Ty-   deriving (Show,Eq)+   deriving (Show,Read,Eq)  data Vdefg    = Rec [Vdef]   | Nonrec Vdef-   deriving (Show,Eq)+   deriving (Show,Read,Eq)  -- Top-level bindings are qualified, so that the printer doesn't have to pass -- around the module name.@@ -31,7 +31,7 @@                  , vdefName  :: Qual Var                  , vdefType  :: Ty                  , vdefExp   :: Exp }-    deriving (Show,Eq)+    deriving (Show,Read,Eq)  data Exp    = Var (Qual Var)@@ -47,18 +47,18 @@   | External String String Ty {- target name, convention, and type -}    | DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -}    | Label String-   deriving (Show,Eq)+   deriving (Show,Read,Eq)  data Bind    = Vb Vbind   | Tb Tbind-   deriving (Show,Eq)+   deriving (Show,Read,Eq)  data Alt    = Acon (Qual Dcon) [Tbind] [Vbind] Exp   | Alit Lit Exp   | Adefault Exp-   deriving (Show,Eq)+   deriving (Show,Read,Eq)  type Vbind = (Qual Var,Ty) type Tbind = (Tvar,Kind)@@ -78,7 +78,7 @@   | InstCoercion Ty Ty   | LeftCoercion Ty   | RightCoercion Ty-   deriving (Show,Eq)+   deriving (Show,Read,Eq)  data Kind    = Klifted@@ -87,14 +87,14 @@   | Kopen   | Karrow Kind Kind   | Keq Ty Ty-   deriving (Show,Eq)+   deriving (Show,Read,Eq)  data Lit    = Lint Integer Ty   | Lrational Rational Ty   | Lchar Char Ty   | Lstring String Ty-   deriving (Show,Eq)+   deriving (Show,Read,Eq)     type Pkgname = Id