DPM 0.2.1 → 0.3.0.0
raw patch · 17 files changed
+1050/−1040 lines, 17 filesdep +DPMdep +HTTPdep +networkdep ~HTFdep ~arraydep ~darcs
Dependencies added: DPM, HTTP, network
Dependency ranges changed: HTF, array, darcs
Files
- DPM.cabal +60/−61
- dist/build/DPM/Core/Lexer.hs +346/−0
- dist/build/DPM/Core/QueryParser.hs +475/−0
- dist/build/dpm/dpm-tmp/DPM/Core/Lexer.hs +0/−346
- dist/build/dpm/dpm-tmp/DPM/Core/QueryParser.hs +0/−492
- src-progs/AllTests.hs +29/−0
- src-progs/CommandlineMain.hs +12/−0
- src/AllTests.hs +0/−29
- src/CommandlineMain.hs +0/−12
- src/DPM/Core/Darcs.hs +66/−65
- src/DPM/Core/Email.hs +1/−1
- src/DPM/Core/PatchBundleParser.hs +12/−8
- src/DPM/Core/Storage.hs +16/−11
- src/DPM/Core/TestDarcs.hs +20/−6
- src/DPM/Tutorial.hs +4/−2
- src/DPM/UI/Commandline/Commands.hs +6/−5
- src/DPM/UI/Commandline/Main.hs +3/−2
DPM.cabal view
@@ -1,8 +1,9 @@ Name: DPM-Version: 0.2.1+-- keep in sync with src/DPM/UI/Commandline/Main.hs+Version: 0.3.0.0 License: GPL License-File: LICENSE-Copyright: (c) 2009-2010 Stefan Wehr+Copyright: (c) 2009-2011 Stefan Wehr Category: Development Author: Stefan Wehr <mail@stefanwehr.de> Maintainer: Stefan Wehr <mail@stefanwehr.de>@@ -18,39 +19,70 @@ of the module "DPM.Tutorial" for a short tutorial. Stability: Beta-Cabal-Version: >= 1.6+Cabal-Version: >= 1.8 Build-Type: Simple+Tested-with: GHC==6.12.1, GHC==6.12.3, GHC==7.0.4 flag test description: Enable the test configuration: Build the test executable, reduce build time. default: False +Library+ Exposed-Modules:+ DPM.UI.Commandline.Commands+ DPM.UI.Commandline.CDPM_Monad+ DPM.UI.Commandline.Main+ DPM.UI.Commandline.Interaction+ DPM.UI.Commandline.ANSIColors+ DPM.Core.Darcs+ DPM.Core.DataTypes+ DPM.Core.Model+ DPM.Core.Storage+ DPM.Core.TestDarcs+ DPM.Core.Utils+ DPM.Core.DPM_Monad+ DPM.Core.Conflicts+ DPM.Core.Email+ DPM.Core.ShortID+ DPM.Core.PatchBundleParser+ DPM.Core.ReverseDependencies+ DPM.Core.Lexer+ DPM.Core.QueryParser+ DPM.Tutorial+ Build-Depends: darcs >=2.5 && <2.6+ , bytestring >= 0.9+ , time+ , old-locale+ , convertible+ , filepath >= 1.1+ , base >= 4 && < 5+ , containers+ , array+ , split+ , mtl+ , syb+ , regex-posix+ , process+ , directory+ , pretty+ , unix+ , HTF == 0.8.*+ , HSH >= 2+ , HTTP == 4000.1.*+ , network == 2.3.*+ , array == 0.3.*+ Build-Tools: alex, happy+ Ghc-Options: -Werror -fwarn-incomplete-patterns -fwarn-tabs+ -fwarn-missing-fields -fwarn-incomplete-record-updates+ -fwarn-duplicate-exports -fwarn-warnings-deprecations+ -fwarn-deprecated-flags -funbox-strict-fields -O2+ Hs-Source-Dirs: src+ Executable dpm-tests Main-Is: AllTests.hs- Hs-Source-Dirs: src- Other-Modules: DPM.Core.Lexer, DPM.Core.QueryParser- -- WARNING: The build-depends property is duplicated for the dpm executable.- -- Can we avoid this somehow?- Build-Depends: darcs >= 2.4- , bytestring >= 0.9- , time- , old-locale- , convertible- , filepath >= 1.1- , base >= 4 && < 5- , containers- , array- , split- , mtl- , syb- , regex-posix- , process- , directory- , pretty- , unix- , HTF >= 0.3- , HSH >= 2+ Hs-Source-Dirs: src-progs+ Build-Depends: base >= 4 && < 5, DPM, bytestring >= 0.9, HTF == 0.8.*, array == 0.3.* if flag(test) Buildable: True else@@ -58,42 +90,9 @@ Executable dpm Main-Is: CommandlineMain.hs- Hs-Source-Dirs: src- Other-Modules: DPM.Core.Lexer, DPM.Core.QueryParser,- DPM.Core.Conflicts, DPM.Core.DataTypes, DPM.Core.Model,- DPM.Core.ReverseDependencies, DPM.Core.TestDarcs,- DPM.Core.DPM_Monad, DPM.Core.Email, DPM.Core.PatchBundleParser,- DPM.Core.ShortID, DPM.Core.Utils, DPM.Core.Darcs, DPM.Core.Storage,- DPM.UI.Commandline.ANSIColors, DPM.UI.Commandline.CDPM_Monad,- DPM.UI.Commandline.Commands, DPM.UI.Commandline.Interaction,- DPM.UI.Commandline.Main- Build-Depends: darcs >= 2.4- , bytestring >= 0.9- , time- , old-locale- , convertible- , filepath >= 1.1- , base >= 4 && < 5- , containers- , array- , split- , mtl- , syb- , regex-posix- , process- , directory- , pretty- , unix- , HTF >= 0.3- , HSH >= 2- -- FIXME: specify dependency on happy and alex- Ghc-Options: -Werror -fwarn-incomplete-patterns -fwarn-tabs -fwarn-missing-fields -fwarn-incomplete-record-updates -fwarn-duplicate-exports -fwarn-warnings-deprecations -fwarn-deprecated-flags -funbox-strict-fields+ Hs-Source-Dirs: src-progs+ Build-Depends: base >= 4 && < 5, DPM Source-Repository head Type: darcs Location: http://www.stefanwehr.de/darcs/DPM---- Just a dummy library to force building the documentation per default-Library- Exposed-Modules: DPM.Tutorial- Hs-Source-Dirs: src
+ dist/build/DPM/Core/Lexer.hs view
@@ -0,0 +1,346 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LINE 1 "src/DPM/Core/Lexer.x" #-}++{-# OPTIONS_GHC -w #-}+module DPM.Core.Lexer (scan, Token(..)) where++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Char (ord)+import Data.Array.Base (unsafeAt)+#else+import Array+import Char (ord)+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+-- -----------------------------------------------------------------------------+-- Alex wrapper code.+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++{-# LINE 18 "templates/wrappers.hs" #-}++-- -----------------------------------------------------------------------------+-- The input type++{-# LINE 35 "templates/wrappers.hs" #-}++{-# LINE 51 "templates/wrappers.hs" #-}++-- -----------------------------------------------------------------------------+-- Token positions++-- `Posn' records the location of a token in the input text. It has three+-- fields: the address (number of chacaters preceding the token), line number+-- and column of a token within the file. `start_pos' gives the position of the+-- start of the file and `eof_pos' a standard encoding for the end of file.+-- `move_pos' calculates the new position after traversing a given character,+-- assuming the usual eight character tab stops.++{-# LINE 74 "templates/wrappers.hs" #-}++-- -----------------------------------------------------------------------------+-- Default monad++{-# LINE 162 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Monad (with ByteString input)++{-# LINE 251 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper+++type AlexInput = (Char,String)++alexGetChar (_, []) = Nothing+alexGetChar (_, c:cs) = Just (c, (c,cs))++alexInputPrevChar (c,_) = c++-- alexScanTokens :: String -> [token]+alexScanTokens str = go ('\n',str)+ where go inp@(_,str) =+ case alexScan inp 0 of+ AlexEOF -> []+ AlexError _ -> error "lexical error"+ AlexSkip inp' len -> go inp'+ AlexToken inp' len act -> act (take len str) : go inp'++++-- -----------------------------------------------------------------------------+-- Basic wrapper, ByteString version++{-# LINE 297 "templates/wrappers.hs" #-}++{-# LINE 322 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper++-- Adds text positions to the basic model.++{-# LINE 339 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper, ByteString version++{-# LINE 354 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- GScan wrapper++-- For compatibility with previous versions of Alex, and because we can.++alex_base :: AlexAddr+alex_base = AlexA# "\xf8\xff\xff\xff\xfd\xff\xff\xff\x02\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x2b\x00\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA# "\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x06\x00\x00\x00\x07\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_check :: AlexAddr+alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x2b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\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\x7b\x00\xff\xff\x7d\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\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\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\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\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_deflt :: AlexAddr+alex_deflt = AlexA# "\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x09\x00"#++alex_accept = listArray (0::Int,9) [[],[(AlexAcc (alex_action_0))],[],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))]]+{-# LINE 18 "src/DPM/Core/Lexer.x" #-}+++data Token = TSpecial -- ':'+ | TNot -- '^'+ | TAnd -- ' '+ | TOr -- ' + '+ | TOpen -- '{'+ | TClose -- '}'+ | TString String+ deriving (Eq,Show)++scan :: String -> [Token]+scan = alexScanTokens++alex_action_0 = \_ -> TOr +alex_action_1 = \_ -> TAnd +alex_action_2 = \_ -> TSpecial +alex_action_3 = \_ -> TNot +alex_action_4 = \_ -> TOpen +alex_action_5 = \_ -> TClose +alex_action_6 = TString +{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++{-# LINE 37 "templates/GenericTemplate.hs" #-}++{-# LINE 47 "templates/GenericTemplate.hs" #-}+++data AlexAddr = AlexA# Addr#++#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+ narrow16Int# i+ where+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2#+#else+ indexInt16OffAddr# arr off+#endif++++++{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN+ narrow32Int# i+ where+ i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+ (b2 `uncheckedShiftL#` 16#) `or#`+ (b1 `uncheckedShiftL#` 8#) `or#` b0)+ b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+ b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+ b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ b0 = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 4#+#else+ indexInt32OffAddr# arr off+#endif++++++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+++++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+ = AlexEOF+ | AlexError !AlexInput+ | AlexSkip !AlexInput !Int+ | AlexToken !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input (I# (sc))+ = alexScanUser undefined input (I# (sc))++alexScanUser user input (I# (sc))+ = case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, input') ->+ case alexGetChar input of+ Nothing -> ++++ AlexEOF+ Just _ ->++++ AlexError input'++ (AlexLastSkip input'' len, _) ->++++ AlexSkip input'' len++ (AlexLastAcc k input''' len, _) ->++++ AlexToken input''' len k+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user orig_input len input s last_acc =+ input `seq` -- strict in the input+ let + new_acc = check_accs (alex_accept `quickIndex` (I# (s)))+ in+ new_acc `seq`+ case alexGetChar input of+ Nothing -> (new_acc, input)+ Just (c, new_input) -> ++++ let+ !(base) = alexIndexInt32OffAddr alex_base s+ !((I# (ord_c))) = ord c+ !(offset) = (base +# ord_c)+ !(check) = alexIndexInt16OffAddr alex_check offset+ + !(new_s) = if (offset >=# 0#) && (check ==# ord_c)+ then alexIndexInt16OffAddr alex_table offset+ else alexIndexInt16OffAddr alex_deflt s+ in+ case new_s of + -1# -> (new_acc, input)+ -- on an error, we want to keep the input *before* the+ -- character that failed, not after.+ _ -> alex_scan_tkn user orig_input (len +# 1#) + new_input new_s new_acc++ where+ check_accs [] = last_acc+ check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))+ check_accs (AlexAccPred a predx : rest)+ | predx user orig_input (I# (len)) input+ = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkipPred predx : rest)+ | predx user orig_input (I# (len)) input+ = AlexLastSkip input (I# (len))+ check_accs (_ : rest) = check_accs rest++data AlexLastAcc a+ = AlexNone+ | AlexLastAcc a !AlexInput !Int+ | AlexLastSkip !AlexInput !Int++data AlexAcc a user+ = AlexAcc a+ | AlexAccSkip+ | AlexAccPred a (AlexAccPred user)+ | AlexAccSkipPred (AlexAccPred user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user in1 len in2+ = p1 user in1 len in2 && p2 user in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input++--alexRightContext :: Int -> AlexAccPred _+alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, _) -> False+ _ -> True+ -- TODO: there's no need to find the longest+ -- match when checking the right context, just+ -- the first match will do.++-- used by wrappers+iUnbox (I# (i)) = i
+ dist/build/DPM/Core/QueryParser.hs view
@@ -0,0 +1,475 @@+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# OPTIONS_GHC -w #-}+module DPM.Core.QueryParser (parseQuery, querySyntax) where++import DPM.Core.DataTypes+import DPM.Core.Lexer+-- import Test.Framework+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.18.5++newtype HappyAbsSyn t4 t5 t6 t7 = 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)+happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn t4 t5 t6 t7) -> t4+happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7)+happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn t4 t5 t6 t7) -> t5+happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7)+happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn t4 t5 t6 t7) -> t6+happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7)+happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn t4 t5 t6 t7) -> t7+happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7)+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn t4 t5 t6 t7) -> (Token)+happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x07\x00\x07\x00\x20\x00\x18\x00\x00\x00\x00\x00\x14\x00\x10\x00\x07\x00\x00\x00\x01\x00\x07\x00\x02\x00\x00\x00\x00\x00\x07\x00\x00\x00\x00\x00\x0b\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x13\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x04\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\xfd\xff\xfb\xff\xf9\xff\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x00\x00\x00\x00\xf7\xff\xfa\xff\x00\x00\xfc\xff\xf8\xff\xfe\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x01\x00\x00\x00\x01\x00\x02\x00\x03\x00\x06\x00\x08\x00\x03\x00\x04\x00\x05\x00\x02\x00\x07\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x07\x00\x04\x00\x05\x00\x02\x00\x07\x00\x01\x00\x02\x00\x03\x00\x02\x00\x03\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x0e\x00\x0c\x00\x0c\x00\x0c\x00\x03\x00\x04\x00\x05\x00\x12\x00\xff\xff\x07\x00\x08\x00\x09\x00\x10\x00\x0a\x00\x02\x00\x03\x00\x04\x00\x05\x00\x0a\x00\x03\x00\x04\x00\x05\x00\x0e\x00\x08\x00\x09\x00\x10\x00\x0a\x00\x12\x00\x04\x00\x05\x00\x10\x00\x05\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = Happy_Data_Array.array (1, 9) [+ (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)+ ]++happy_n_terms = 9 :: Int+happy_n_nonterms = 4 :: Int++happyReduce_1 = happySpecReduce_3 0# happyReduction_1+happyReduction_1 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut4 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn4+ (QOr happy_var_1 happy_var_3+ )}}++happyReduce_2 = happySpecReduce_1 0# happyReduction_2+happyReduction_2 happy_x_1+ = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn4+ (happy_var_1+ )}++happyReduce_3 = happySpecReduce_3 1# happyReduction_3+happyReduction_3 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_3 of { happy_var_3 -> + happyIn5+ (QAnd happy_var_1 happy_var_3+ )}}++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_2 2# happyReduction_5+happyReduction_5 happy_x_2+ happy_x_1+ = case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn6+ (QNot happy_var_2+ )}++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 3# happyReduction_7+happyReduction_7 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn7+ (happy_var_2+ )}++happyReduce_8 = happySpecReduce_2 3# happyReduction_8+happyReduction_8 happy_x_2+ happy_x_1+ = case happyOutTok happy_x_2 of { (TString happy_var_2) -> + happyIn7+ (trySpecial happy_var_2+ )}++happyReduce_9 = happySpecReduce_1 3# happyReduction_9+happyReduction_9 happy_x_1+ = case happyOutTok happy_x_1 of { (TString happy_var_1) -> + happyIn7+ (QPrim happy_var_1+ )}++happyNewToken action sts stk [] =+ happyDoAction 8# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+ let cont i = happyDoAction i tk action sts stk tks in+ case tk of {+ TOr -> cont 1#;+ TAnd -> cont 2#;+ TNot -> cont 3#;+ TSpecial -> cont 4#;+ TOpen -> cont 5#;+ TClose -> cont 6#;+ TString happy_dollar_dollar -> cont 7#;+ _ -> happyError' (tk:tks)+ }++happyError_ tk tks = happyError' (tk:tks)++happyThen :: () => Maybe a -> (a -> Maybe b) -> Maybe b+happyThen = (>>=)+happyReturn :: () => a -> Maybe a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> Maybe a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(Token)] -> Maybe a+happyError' = parseError++parse tks = happySomeParser where+ happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++querySyntax :: String+querySyntax = unlines $+ ["Query ::= Query ' + ' Query -- logical OR"+ ," | Query ' ' Query -- logical AND"+ ," | '^' Query -- logical NOT"+ ," | '{' Query '}' -- grouping"+ ," | ':' Special"+ ," | String"+ ,""+ ,"Special is one of \"undecided\", \"rejected\", \"obsolete\", \"applied\","+ ,"\"reviewed\", \"open\", or \"closed\", and String is an arbitrary sequence "+ ,"of non-whitespace characters not starting with '^', '{', '}', '+', or ':'."]++parseError :: [Token] -> Maybe a+parseError _ = Nothing++trySpecial :: String -> Query+trySpecial s =+ case s of+ "undecided" -> QState PatchStateUNDECIDED+ "rejected" -> QState (PatchStateDISCARDED ReasonRejected)+ "obsolete" -> QState (PatchStateDISCARDED ReasonObsolete)+ "applied" -> QState PatchStateAPPLIED+ "reviewed" -> QReviewed+ "open" -> QGroupState PatchGroupOpen+ "closed" -> QGroupState PatchGroupClosed+ _ -> QPrim s++parseQuery :: String -> Maybe Query+parseQuery = parse . scan++-- FIXME: tests+{-# 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 30 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList++++++{-# LINE 51 "templates/GenericTemplate.hs" #-}++{-# LINE 61 "templates/GenericTemplate.hs" #-}++{-# LINE 70 "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 Happy_GHC_Exts.<# (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 (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#))+ then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i)+ else False+ !(action)+ | check = indexShortOffAddr happyTable off_i+ | otherwise = indexShortOffAddr happyDefActions st++{-# LINE 130 "templates/GenericTemplate.hs" #-}+++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 163 "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 =+ 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 Happy_GHC_Exts.+# nt)+ !(new_state) = indexShortOffAddr happyTable off_i+++++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 =+-- 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 ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)++-- Internal happy errors:++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/dpm/dpm-tmp/DPM/Core/Lexer.hs
@@ -1,346 +0,0 @@-{-# OPTIONS -fglasgow-exts -cpp #-}-{-# LINE 1 "src/DPM/Core/Lexer.x" #-}--{-# OPTIONS_GHC -w #-}-module DPM.Core.Lexer (scan, Token(..)) where--#if __GLASGOW_HASKELL__ >= 603-#include "ghcconfig.h"-#elif defined(__GLASGOW_HASKELL__)-#include "config.h"-#endif-#if __GLASGOW_HASKELL__ >= 503-import Data.Array-import Data.Char (ord)-import Data.Array.Base (unsafeAt)-#else-import Array-import Char (ord)-#endif-#if __GLASGOW_HASKELL__ >= 503-import GHC.Exts-#else-import GlaExts-#endif-{-# LINE 1 "templates/wrappers.hs" #-}-{-# LINE 1 "templates/wrappers.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command line>" #-}-{-# LINE 1 "templates/wrappers.hs" #-}--- -------------------------------------------------------------------------------- Alex wrapper code.------ This code is in the PUBLIC DOMAIN; you may copy it freely and use--- it for any purpose whatsoever.--{-# LINE 18 "templates/wrappers.hs" #-}---- -------------------------------------------------------------------------------- The input type--{-# LINE 35 "templates/wrappers.hs" #-}--{-# LINE 51 "templates/wrappers.hs" #-}---- -------------------------------------------------------------------------------- Token positions---- `Posn' records the location of a token in the input text. It has three--- fields: the address (number of chacaters preceding the token), line number--- and column of a token within the file. `start_pos' gives the position of the--- start of the file and `eof_pos' a standard encoding for the end of file.--- `move_pos' calculates the new position after traversing a given character,--- assuming the usual eight character tab stops.--{-# LINE 74 "templates/wrappers.hs" #-}---- -------------------------------------------------------------------------------- Default monad--{-# LINE 162 "templates/wrappers.hs" #-}----- -------------------------------------------------------------------------------- Monad (with ByteString input)--{-# LINE 251 "templates/wrappers.hs" #-}----- -------------------------------------------------------------------------------- Basic wrapper---type AlexInput = (Char,String)--alexGetChar (_, []) = Nothing-alexGetChar (_, c:cs) = Just (c, (c,cs))--alexInputPrevChar (c,_) = c---- alexScanTokens :: String -> [token]-alexScanTokens str = go ('\n',str)- where go inp@(_,str) =- case alexScan inp 0 of- AlexEOF -> []- AlexError _ -> error "lexical error"- AlexSkip inp' len -> go inp'- AlexToken inp' len act -> act (take len str) : go inp'------ -------------------------------------------------------------------------------- Basic wrapper, ByteString version--{-# LINE 297 "templates/wrappers.hs" #-}--{-# LINE 322 "templates/wrappers.hs" #-}----- -------------------------------------------------------------------------------- Posn wrapper---- Adds text positions to the basic model.--{-# LINE 339 "templates/wrappers.hs" #-}----- -------------------------------------------------------------------------------- Posn wrapper, ByteString version--{-# LINE 354 "templates/wrappers.hs" #-}----- -------------------------------------------------------------------------------- GScan wrapper---- For compatibility with previous versions of Alex, and because we can.--alex_base :: AlexAddr-alex_base = AlexA# "\xf8\xff\xff\xff\xfd\xff\xff\xff\x02\x00\x00\x00\x07\x00\x00\x00\x1f\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x30\x00\x00\x00"#--alex_table :: AlexAddr-alex_table = AlexA# "\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xff\xff\x00\x00\x00\x00\x00\x00\x02\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x06\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\xff\xff\x00\x00\x00\x00\x00\x00\x03\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\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\x08\x00\x00\x00\x09\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--alex_check :: AlexAddr-alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x2b\x00\xff\xff\xff\xff\xff\xff\x20\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3a\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x20\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\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\x7b\x00\xff\xff\x7d\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\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\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\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\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--alex_deflt :: AlexAddr-alex_deflt = AlexA# "\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0b\x00"#--alex_accept = listArray (0::Int,11) [[],[],[(AlexAcc (alex_action_0))],[],[],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))]]-{-# LINE 18 "src/DPM/Core/Lexer.x" #-}---data Token = TSpecial -- ':'- | TNot -- '^'- | TAnd -- ' '- | TOr -- ' + '- | TOpen -- '{'- | TClose -- '}'- | TString String- deriving (Eq,Show)--scan :: String -> [Token]-scan = alexScanTokens--alex_action_0 = \_ -> TOr -alex_action_1 = \_ -> TAnd -alex_action_2 = \_ -> TSpecial -alex_action_3 = \_ -> TNot -alex_action_4 = \_ -> TOpen -alex_action_5 = \_ -> TClose -alex_action_6 = TString -{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- -------------------------------------------------------------------------------- ALEX TEMPLATE------ This code is in the PUBLIC DOMAIN; you may copy it freely and use--- it for any purpose whatsoever.---- -------------------------------------------------------------------------------- INTERNALS and main scanner engine--{-# LINE 35 "templates/GenericTemplate.hs" #-}--{-# LINE 45 "templates/GenericTemplate.hs" #-}---data AlexAddr = AlexA# Addr#--#if __GLASGOW_HASKELL__ < 503-uncheckedShiftL# = shiftL#-#endif--{-# INLINE alexIndexInt16OffAddr #-}-alexIndexInt16OffAddr (AlexA# arr) off =-#ifdef WORDS_BIGENDIAN- narrow16Int# i- where- i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)- high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))- low = int2Word# (ord# (indexCharOffAddr# arr off'))- off' = off *# 2#-#else- indexInt16OffAddr# arr off-#endif------{-# INLINE alexIndexInt32OffAddr #-}-alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN- narrow32Int# i- where- i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`- (b2 `uncheckedShiftL#` 16#) `or#`- (b1 `uncheckedShiftL#` 8#) `or#` b0)- b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))- b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))- b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))- b0 = int2Word# (ord# (indexCharOffAddr# arr off'))- off' = off *# 4#-#else- indexInt32OffAddr# arr off-#endif------#if __GLASGOW_HASKELL__ < 503-quickIndex arr i = arr ! i-#else--- GHC >= 503, unsafeAt is available from Data.Array.Base.-quickIndex = unsafeAt-#endif------- -------------------------------------------------------------------------------- Main lexing routines--data AlexReturn a- = AlexEOF- | AlexError !AlexInput- | AlexSkip !AlexInput !Int- | AlexToken !AlexInput !Int a---- alexScan :: AlexInput -> StartCode -> AlexReturn a-alexScan input (I# (sc))- = alexScanUser undefined input (I# (sc))--alexScanUser user input (I# (sc))- = case alex_scan_tkn user input 0# input sc AlexNone of- (AlexNone, input') ->- case alexGetChar input of- Nothing -> ---- AlexEOF- Just _ ->---- AlexError input'-- (AlexLastSkip input len, _) ->---- AlexSkip input len-- (AlexLastAcc k input len, _) ->---- AlexToken input len k----- Push the input through the DFA, remembering the most recent accepting--- state it encountered.--alex_scan_tkn user orig_input len input s last_acc =- input `seq` -- strict in the input- let - new_acc = check_accs (alex_accept `quickIndex` (I# (s)))- in- new_acc `seq`- case alexGetChar input of- Nothing -> (new_acc, input)- Just (c, new_input) -> ---- let- base = alexIndexInt32OffAddr alex_base s- (I# (ord_c)) = ord c- offset = (base +# ord_c)- check = alexIndexInt16OffAddr alex_check offset- - new_s = if (offset >=# 0#) && (check ==# ord_c)- then alexIndexInt16OffAddr alex_table offset- else alexIndexInt16OffAddr alex_deflt s- in- case new_s of - -1# -> (new_acc, input)- -- on an error, we want to keep the input *before* the- -- character that failed, not after.- _ -> alex_scan_tkn user orig_input (len +# 1#) - new_input new_s new_acc-- where- check_accs [] = last_acc- check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))- check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))- check_accs (AlexAccPred a pred : rest)- | pred user orig_input (I# (len)) input- = AlexLastAcc a input (I# (len))- check_accs (AlexAccSkipPred pred : rest)- | pred user orig_input (I# (len)) input- = AlexLastSkip input (I# (len))- check_accs (_ : rest) = check_accs rest--data AlexLastAcc a- = AlexNone- | AlexLastAcc a !AlexInput !Int- | AlexLastSkip !AlexInput !Int--data AlexAcc a user- = AlexAcc a- | AlexAccSkip- | AlexAccPred a (AlexAccPred user)- | AlexAccSkipPred (AlexAccPred user)--type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool---- -------------------------------------------------------------------------------- Predicates on a rule--alexAndPred p1 p2 user in1 len in2- = p1 user in1 len in2 && p2 user in1 len in2----alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input----alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input----alexRightContext :: Int -> AlexAccPred _-alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of- (AlexNone, _) -> False- _ -> True- -- TODO: there's no need to find the longest- -- match when checking the right context, just- -- the first match will do.---- used by wrappers-iUnbox (I# (i)) = i
− dist/build/dpm/dpm-tmp/DPM/Core/QueryParser.hs
@@ -1,492 +0,0 @@-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}-{-# OPTIONS -fglasgow-exts -cpp #-}-{-# OPTIONS_GHC -w #-}-module DPM.Core.QueryParser (parseQuery, querySyntax) where--import DPM.Core.DataTypes-import DPM.Core.Lexer--- import Test.Framework-#if __GLASGOW_HASKELL__ >= 503-import qualified Data.Array as Happy_Data_Array-#else-import qualified Array as Happy_Data_Array-#endif-#if __GLASGOW_HASKELL__ >= 503-import qualified GHC.Exts as Happy_GHC_Exts-#else-import qualified GlaExts as Happy_GHC_Exts-#endif---- parser produced by Happy Version 1.18.4--newtype HappyAbsSyn t4 t5 t6 t7 = 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)-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn t4 t5 t6 t7) -> t4-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7)-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn t4 t5 t6 t7) -> t5-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7)-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn t4 t5 t6 t7) -> t6-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7)-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn t4 t5 t6 t7) -> t7-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7)-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn t4 t5 t6 t7) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x07\x00\x07\x00\x20\x00\x18\x00\x00\x00\x00\x00\x14\x00\x10\x00\x07\x00\x00\x00\x01\x00\x07\x00\x02\x00\x00\x00\x00\x00\x07\x00\x00\x00\x00\x00\x0b\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x13\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x04\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\xfd\xff\xfb\xff\xf9\xff\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x00\x00\x00\x00\xf7\xff\xfa\xff\x00\x00\xfc\xff\xf8\xff\xfe\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x01\x00\x00\x00\x01\x00\x02\x00\x03\x00\x06\x00\x08\x00\x03\x00\x04\x00\x05\x00\x02\x00\x07\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x07\x00\x04\x00\x05\x00\x02\x00\x07\x00\x01\x00\x02\x00\x03\x00\x02\x00\x03\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x0e\x00\x0c\x00\x0c\x00\x0c\x00\x03\x00\x04\x00\x05\x00\x12\x00\xff\xff\x07\x00\x08\x00\x09\x00\x10\x00\x0a\x00\x02\x00\x03\x00\x04\x00\x05\x00\x0a\x00\x03\x00\x04\x00\x05\x00\x0e\x00\x08\x00\x09\x00\x10\x00\x0a\x00\x12\x00\x04\x00\x05\x00\x10\x00\x05\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (1, 9) [- (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)- ]--happy_n_terms = 9 :: Int-happy_n_nonterms = 4 :: Int--happyReduce_1 = happySpecReduce_3 0# happyReduction_1-happyReduction_1 happy_x_3- happy_x_2- happy_x_1- = case happyOut4 happy_x_1 of { happy_var_1 -> - case happyOut5 happy_x_3 of { happy_var_3 -> - happyIn4- (QOr happy_var_1 happy_var_3- )}}--happyReduce_2 = happySpecReduce_1 0# happyReduction_2-happyReduction_2 happy_x_1- = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4- (happy_var_1- )}--happyReduce_3 = happySpecReduce_3 1# happyReduction_3-happyReduction_3 happy_x_3- happy_x_2- happy_x_1- = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn5- (QAnd happy_var_1 happy_var_3- )}}--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_2 2# happyReduction_5-happyReduction_5 happy_x_2- happy_x_1- = case happyOut7 happy_x_2 of { happy_var_2 -> - happyIn6- (QNot happy_var_2- )}--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 3# happyReduction_7-happyReduction_7 happy_x_3- happy_x_2- happy_x_1- = case happyOut4 happy_x_2 of { happy_var_2 -> - happyIn7- (happy_var_2- )}--happyReduce_8 = happySpecReduce_2 3# happyReduction_8-happyReduction_8 happy_x_2- happy_x_1- = case happyOutTok happy_x_2 of { (TString happy_var_2) -> - happyIn7- (trySpecial happy_var_2- )}--happyReduce_9 = happySpecReduce_1 3# happyReduction_9-happyReduction_9 happy_x_1- = case happyOutTok happy_x_1 of { (TString happy_var_1) -> - happyIn7- (QPrim happy_var_1- )}--happyNewToken action sts stk [] =- happyDoAction 8# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =- let cont i = happyDoAction i tk action sts stk tks in- case tk of {- TOr -> cont 1#;- TAnd -> cont 2#;- TNot -> cont 3#;- TSpecial -> cont 4#;- TOpen -> cont 5#;- TClose -> cont 6#;- TString happy_dollar_dollar -> cont 7#;- _ -> happyError' (tk:tks)- }--happyError_ tk tks = happyError' (tk:tks)--happyThen :: () => Maybe a -> (a -> Maybe b) -> Maybe b-happyThen = (>>=)-happyReturn :: () => a -> Maybe a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> Maybe a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> Maybe a-happyError' = parseError--parse tks = happySomeParser where- happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))--happySeq = happyDontSeq---querySyntax :: String-querySyntax = unlines $- ["Query ::= Query ' + ' Query -- logical OR"- ," | Query ' ' Query -- logical AND"- ," | '^' Query -- logical NOT"- ," | '{' Query '}' -- grouping"- ," | ':' Special"- ," | String"- ,""- ,"Special is one of \"undecided\", \"rejected\", \"obsolete\", \"applied\","- ,"\"reviewed\", \"open\", or \"closed\", and String is an arbitrary sequence "- ,"of non-whitespace characters not starting with '^', '{', '}', '+', or ':'."]--parseError :: [Token] -> Maybe a-parseError _ = Nothing--trySpecial :: String -> Query-trySpecial s =- case s of- "undecided" -> QState PatchStateUNDECIDED- "rejected" -> QState (PatchStateDISCARDED ReasonRejected)- "obsolete" -> QState (PatchStateDISCARDED ReasonObsolete)- "applied" -> QState PatchStateAPPLIED- "reviewed" -> QReviewed- "open" -> QGroupState PatchGroupOpen- "closed" -> QGroupState PatchGroupClosed- _ -> QPrim s--parseQuery :: String -> Maybe Query-parseQuery = parse . scan---- FIXME: tests-{-# 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 Happy_GHC_Exts.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 Happy_GHC_Exts.<# (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 (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#))- then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# 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- Happy_GHC_Exts.narrow16Int# i-#elif __GLASGOW_HASKELL__ == 500- Happy_GHC_Exts.intToInt16# i-#else- Happy_GHC_Exts.iShiftRA# (Happy_GHC_Exts.iShiftL# i 16#) 16#-#endif- where-#if __GLASGOW_HASKELL__ >= 503- i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)-#else- i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.shiftL# high 8#) low)-#endif- 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 170 "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 =- 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 Happy_GHC_Exts.+# nt)- new_state = indexShortOffAddr happyTable off_i-----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 =--- 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 ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)---- Internal happy errors:--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.
+ src-progs/AllTests.hs view
@@ -0,0 +1,29 @@+import qualified DPM.Core.TestDarcs+import qualified DPM.Core.Model+import qualified DPM.Core.Utils+import qualified DPM.Core.Storage+import qualified DPM.Core.ShortID+import qualified DPM.Core.QueryParser+import qualified DPM.Core.ReverseDependencies++import System.Environment+import Test.Framework++import qualified Data.ByteString as B+import qualified DPM.Core.Darcs as Darcs+import DPM.Core.DataTypes ( PatchData(..), PatchID(..) )++allTestSuites :: [TestSuite]+allTestSuites = [DPM.Core.TestDarcs.allHTFTests+ ,DPM.Core.Model.allHTFTests+ ,DPM.Core.Utils.allHTFTests+ ,DPM.Core.ShortID.allHTFTests+ ,DPM.Core.ReverseDependencies.allHTFTests+ ]++testSuite :: TestSuite+testSuite = makeAnonTestSuite (map testSuiteAsTest allTestSuites)++main =+ do args <- getArgs+ runTestWithArgs args testSuite
+ src-progs/CommandlineMain.hs view
@@ -0,0 +1,12 @@+module Main where++import System.Environment++import qualified DPM.UI.Commandline.Main as M++mainWithArgs = M.mainWithArgs+ +main = + do args <- getArgs+ mainWithArgs args+
− src/AllTests.hs
@@ -1,29 +0,0 @@-import qualified DPM.Core.TestDarcs-import qualified DPM.Core.Model-import qualified DPM.Core.Utils-import qualified DPM.Core.Storage-import qualified DPM.Core.ShortID-import qualified DPM.Core.QueryParser-import qualified DPM.Core.ReverseDependencies--import System.Environment-import Test.Framework--import qualified Data.ByteString as B-import qualified DPM.Core.Darcs as Darcs-import DPM.Core.DataTypes ( PatchData(..), PatchID(..) )--allTestSuites :: [TestSuite]-allTestSuites = [DPM.Core.TestDarcs.allHTFTests- ,DPM.Core.Model.allHTFTests- ,DPM.Core.Utils.allHTFTests- ,DPM.Core.ShortID.allHTFTests- ,DPM.Core.ReverseDependencies.allHTFTests- ]--testSuite :: TestSuite-testSuite = makeAnonTestSuite (map testSuiteAsTest allTestSuites)--main =- do args <- getArgs- runTestWithArgs args testSuite
− src/CommandlineMain.hs
@@ -1,12 +0,0 @@-module Main where--import System.Environment--import qualified DPM.UI.Commandline.Main as M--mainWithArgs = M.mainWithArgs- -main = - do args <- getArgs- mainWithArgs args-
src/DPM/Core/Darcs.hs view
@@ -26,36 +26,39 @@ import Text.PrettyPrint import Data.Convertible import HSH+import Data.List ( (\\) ) -- imports from darcs import Progress ( setProgressMode ) import Darcs.Patch (RepoPatch, commute, invert, description)-import Darcs.Email (read_email)+import Darcs.Email (readEmail) import Darcs.Commands (commandCommand) import qualified Darcs.Commands.Apply import Darcs.External (signString, verifyPS) import Darcs.Flags (DarcsFlag(Unified, WorkRepoDir, FixFilePath, Quiet, Verbose, NoAllowConflicts, Interactive, Test, OnePattern)) import Darcs.Patch.MatchData ( PatchMatch(..) )-import Darcs.Hopefully (PatchInfoAnd, hopefully, info, n2pia,+import Darcs.Patch.Set ( PatchSet, newset2RL )+import Darcs.Hopefully (PatchInfoAnd, hopefully, hopefullyM, info, n2pia, conscientiously) import Darcs.Witnesses.Ordered (FL(..), RL(..), MyEq(unsafeCompare), mapFL_FL,- mapRL_RL, concatRL, (:>)(..), (:\/:)(..),- mapFL, mapRL, reverseRL,- unsafeUnRL)-import Darcs.Patch.Bundle (make_bundle, scan_bundle)-import Darcs.Patch.Depends (get_common_and_uncommon_or_missing)-import Darcs.Patch.Info (PatchInfo(..), human_friendly,- make_filename, pi_author, pi_date, pi_log, pi_name)+ mapRL_RL, concatRL,+ (:>)(..), (:>>)(..), (:\/:)(..),+ mapFL, mapRL, reverseRL)+import Darcs.Patch.Bundle (makeBundle, scanBundle)+import Darcs.Patch.Info (PatchInfo(..), humanFriendly, isInverted,+ makeFilename, piAuthor, piDate, piLog, piName) import Darcs.RepoPath (AbsolutePath, makeAbsolute, FilePathLike(..), rootDirectory)+import Darcs.Patch.Depends ( findUncommon, findCommonWithThem ) import Darcs.Repository (Repository) import Darcs.Repository.Merge (considerMergeToWorking)-import Darcs.Repository.Internal (SealedPatchSet, read_repo,- slurp_recorded, withRepositoryDirectory)+import Darcs.Repository.Internal (SealedPatchSet, readRepo,+ withRepositoryDirectory) import Darcs.Witnesses.Sealed (Sealed(..)) import Darcs.Patch.Prim (fromPrim)-import qualified Printer as P (errorDoc, text, ($$), renderPS)+import qualified Printer as P (errorDoc, text, ($$), renderPS, renderString,+ vcat) import ByteStringUtils (linesPS, unlinesPS) -- DPM imports@@ -77,12 +80,12 @@ let i = info p pid = getPatchID p in Patch { p_id = pid- , p_date = convert $ pi_date i- , p_name = PatchGroupID (pi_name i)- , p_author = pi_author i- , p_darcsLog = pi_log i+ , p_date = convert $ piDate i+ , p_name = PatchGroupID (piName i)+ , p_author = piAuthor i+ , p_darcsLog = piLog i , p_log = []- , p_inverted = is_inverted i+ , p_inverted = isInverted i , p_state = PatchStateUNDECIDED , p_tags = [] , p_dependents = map getPatchID ps@@ -117,7 +120,7 @@ | otherwise = x :>: (takeFL (n-1) xs) getPatchID :: RepoPatch p => PatchInfoAnd p -> PatchID-getPatchID p = PatchID (dropExtensions $ make_filename (info p))+getPatchID p = PatchID (dropExtensions $ makeFilename (info p)) exceptionAsString :: SomeException -> String exceptionAsString e =@@ -172,48 +175,46 @@ deriving Show processPatchBundle :: forall a . String -> [DarcsFlag] -> B.ByteString- -> (forall p . RepoPatch p =>- Repository p- -> [PatchInfo] -- common patches- -> RL (PatchInfoAnd p) -- extra repo patches- -> FL (PatchInfoAnd p) -- bundle patches- -> IO a)+ -> (forall p . RepoPatch p+ => Repository p+ -- -> [PatchInfo] -- common patches+ -- -> RL (PatchInfoAnd p) -- extra repo patches+ -> FL (PatchInfoAnd p) -- bundle patches+ -> IO a) -> IO a processPatchBundle repoDir opts bundleData fun = bracketCD repoDir (withRepositoryDirectory opts "." run) where- run :: RepoPatch p => Repository p -> IO a+ run :: forall p . RepoPatch p => Repository p -> IO a run repository = do let ps = bundleData- repoPatches <- read_repo repository- bundlePatchesEither <- get_patch_bundle opts ps+ repoPatches <- readRepo repository+ bundlePatchesEither <- getPatchBundle opts ps bundlePatches <- case bundlePatchesEither of Right (Sealed t) -> return t Left err -> fail err- (common, repoPatches':\/:bundlePatches') <-- case get_common_and_uncommon_or_missing (repoPatches, bundlePatches)- of- Left pinfo ->- if pinfo `elem` mapRL info (concatRL repoPatches)- then cannotApplyPartialRepo pinfo ""- else cannotApplyMissing pinfo- Right x -> return x+ let ((common :: PatchSet p) :>> _) = findCommonWithThem repoPatches bundlePatches+ -- all patches that are in "them" and not in "common" need to+ -- be available; check that+ let common_i = mapRL info $ newset2RL common+ them_i = mapRL info $ newset2RL bundlePatches+ required = them_i \\ common_i -- FIXME quadratic?+ check :: RL (PatchInfoAnd p) -> [PatchInfo] -> IO ()+ check (p :<: ps') bad = case hopefullyM p of+ Nothing | info p `elem` required -> check ps' (info p : bad)+ _ -> check ps' bad+ check NilRL [] = return ()+ check NilRL bad = fail . P.renderString $ P.vcat $ map humanFriendly bad +++ [P.text "\nFATAL: Cannot apply this bundle. We are missing the above patches." ]+ check (newset2RL bundlePatches) []+ (repoPatches':\/:bundlePatches') <- return $ findUncommon repoPatches bundlePatches let bundlePatches'' = mapFL_FL (n2pia . conscientiously (P.text ("We cannot process this patch " ++ "bundle, since we're " ++ "missing:") P.$$))- $ reverseRL $ bundlePatches'- fun repository common repoPatches' bundlePatches''- cannotApplyMissing pinfo- = P.errorDoc $ P.text ("Cannot apply this patch bundle, "- ++ "since we're missing:")- P.$$ human_friendly pinfo- cannotApplyPartialRepo pinfo e- = P.errorDoc $ P.text ("Cannot apply this patch bundle, "- ++ "this is a \"--partial repository")- P.$$ P.text "We don't have the following patch:"- P.$$ human_friendly pinfo P.$$ P.text e+ $ bundlePatches'+ fun repository bundlePatches'' conflictsBundleWithRepo :: String -> B.ByteString -> IO Bool conflictsBundleWithRepo repoDir bundleData = return False@@ -238,7 +239,7 @@ let opts = [] handle (\ e -> return (Left (exceptionAsString e))) $ processPatchBundle repoDir opts bundleData $- \repository common repoPatches bundlePatches ->+ \repository bundlePatches -> do let deps = computeDependencies bundlePatches conflicts <- return [] -- conflicts <- computeConflicts repository possibleConflicts@@ -260,25 +261,25 @@ return p forceConflicts = evaluate . length . show -get_patch_bundle :: RepoPatch p => [DarcsFlag] -> B.ByteString+getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString -> IO (Either String (SealedPatchSet p))-get_patch_bundle opts fps = do- mps <- verifyPS opts $ read_email fps+getPatchBundle opts fps = do+ mps <- verifyPS opts $ readEmail fps mops <- verifyPS opts fps case (mps, mops) of (Nothing, Nothing) -> return $ Left "Patch bundle not properly signed, or gpg failed."- (Just ps, Nothing) -> return $ scan_bundle ps- (Nothing, Just ps) -> return $ scan_bundle ps- -- We use careful_scan_bundle only below because in either of the two+ (Just ps, Nothing) -> return $ scanBundle ps+ (Nothing, Just ps) -> return $ scanBundle ps+ -- We use careful_scanBundle only below because in either of the two -- above case we know the patch was signed, so it really shouldn't -- need stripping of CRs.- (Just ps1, Just ps2) -> case careful_scan_bundle ps1 of- Left _ -> return $ careful_scan_bundle ps2+ (Just ps1, Just ps2) -> case careful_scanBundle ps1 of+ Left _ -> return $ careful_scanBundle ps2 Right x -> return $ Right x- where careful_scan_bundle ps =- case scan_bundle ps of- Left e -> case scan_bundle $ stripCrPS ps of+ where careful_scanBundle ps =+ case scanBundle ps of+ Left e -> case scanBundle $ stripCrPS ps of Right x -> Right x _ -> Left e x -> x@@ -324,11 +325,11 @@ makeSimplePatch p = let i = info p in SimplePatch { sp_id = getPatchID p- , sp_date = convert $ pi_date i- , sp_name = PatchGroupID (pi_name i)- , sp_author = pi_author i- , sp_darcsLog = pi_log i- , sp_inverted = is_inverted i+ , sp_date = convert $ piDate i+ , sp_name = PatchGroupID (piName i)+ , sp_author = piAuthor i+ , sp_darcsLog = piLog i+ , sp_inverted = isInverted i } getPatchesInRepo :: FilePath -> IO (Either String [SimplePatch])@@ -337,8 +338,8 @@ let opts = [] handle (\e -> return (Left (exceptionAsString e))) $ withRepositoryDirectory opts repoDir $ \repository ->- do patches <- read_repo repository- let l = mapRL makeSimplePatch (concatRL patches)+ do patches <- readRepo repository+ let l = mapRL makeSimplePatch (newset2RL patches) mapM forceSimplePatch l return (Right l) where
src/DPM/Core/Email.hs view
@@ -111,7 +111,7 @@ Right x -> return x readDarcsEmail :: B.ByteString -> B.ByteString-readDarcsEmail = Darcs.Email.read_email+readDarcsEmail = Darcs.Email.readEmail -- Local Variables: -- coding: utf-8
src/DPM/Core/PatchBundleParser.hs view
@@ -65,7 +65,7 @@ | otherwise -> case breakOn '*' $ B.tail s' of (!author,s2) | B.null s2 -> error "Broken file (2)"- | otherwise ->+ | otherwise -> case B.break (\c->c==']'||c=='\n') $ B.drop 2 s2 of (!ct,!s''') -> do (!log, !s4) <-@@ -110,6 +110,7 @@ Nothing -> Nothing Just n -> Just (B.take n p, B.drop (n+1) p) +-- This function seems to cause a stack overflow when compiled *without* -O2. scanBundle :: ByteString -> Either String PatchBundle scanBundle ps | B.null ps = Left "Bad patch bundle!"@@ -141,13 +142,16 @@ returnResult list = Right list get_patches :: ByteString -> ([(PatchInfo,ByteString)], ByteString)-get_patches ps =- case readPatchInfo ps of- Nothing -> ([], ps)- Just (pinfo,ps) ->- case readDiff ps of- Nothing -> ([], ps)- Just (diff, r) -> (pinfo, diff) -:- get_patches r+get_patches ps = get_patches' ps []+ where+ get_patches' ps acc =+ case readPatchInfo ps of+ Nothing -> (reverse acc, ps)+ Just (pinfo,ps) ->+ case readDiff ps of+ Nothing -> (reverse acc, ps)+ Just (diff, r) ->+ get_patches' r ((pinfo, diff) : acc) silly_lex :: ByteString -> (String, ByteString)
src/DPM/Core/Storage.hs view
@@ -155,7 +155,9 @@ show pid ++ " not found") Just (_, PatchBundleName name) -> do dir <- getDPMConfigValue cfg_dataDir- return (dir </> name)+ let fname = (dir </> name)+ debugDPM ("Filename for patch " ++ show pid ++ ": " ++ fname)+ return fname withModelAndPatchesLogPG :: (M.Model -> Patches -> (M.Partial M.Model, Patches, PatchGroupID, String))@@ -208,16 +210,19 @@ addPatch :: Patch -> PatchBundleName -> [PatchID] -> Bool -> DPM Bool addPatch p bundleName conflicts conflictWithRepo =- withModelAndPatchesDPM $ \model patches ->- case M.addPatch model (p_id p) (p_name p) (p_dependents p)- conflicts conflictWithRepo- of- Left err -> return (Left err, patches, p_id p, "added")- Right model' ->- do return (Right model',- insertPatch p bundleName patches,- p_id p,- "added")+ do debugDPM ("Adding patch " ++ unPatchID (p_id p) ++ " (" +++ unPatchGroupID (p_name p) ++ "), dependents: " +++ show (p_dependents p))+ withModelAndPatchesDPM $ \model patches ->+ case M.addPatch model (p_id p) (p_name p) (p_dependents p)+ conflicts conflictWithRepo+ of+ Left err -> return (Left err, patches, p_id p, "added")+ Right model' ->+ do return (Right model',+ insertPatch p bundleName patches,+ p_id p,+ "added") markAsReviewed :: PatchID -> Comment -> DPM Bool markAsReviewed pid comment = withModelAndPatches $
src/DPM/Core/TestDarcs.hs view
@@ -10,7 +10,7 @@ import System.FilePath import Control.Exception ( bracket_, catch, SomeException ) import Prelude hiding ( catch )-import Data.List ( isPrefixOf )+import Data.List ( isInfixOf, isPrefixOf ) import qualified Data.ByteString.Char8 as B import System.IO import Text.PrettyPrint@@ -30,12 +30,15 @@ withRepoRoot = withTempDir repoRoot withTempDir :: FilePath -> IO a -> IO a-withTempDir dir action =+withTempDir dir action = withTempDirNoCD dir (bracketCD dir action)++withTempDirNoCD :: FilePath -> IO a -> IO a+withTempDirNoCD dir action = bracket_ (do runIO ("rm", ["-rf", dir]) runIO ("mkdir", [dir])) (do runIO ("rm", ["-rf", dir]) `catch` \(e::SomeException) -> return ())- (bracketCD dir action)+ action setupRepos :: IO () setupRepos =@@ -74,7 +77,7 @@ ,"darcs add y" ,"darcs record --no-ask-deps -a -m " ++ "'INDEPENDENT'"- ,"darcs send -a -o ../bundle"]+ ,"darcs send --dont-edit-description -a -o ../bundle ../A"] test_ok = withRepoRoot $ do setupRepos@@ -114,8 +117,7 @@ bundle <- B.readFile "bundle" eith <- readPatchBundle "A" bundle s <- assertLeft eith- assertBool ("We cannot process this patch bundle, since we're missing"- `isPrefixOf` s)+ assertBool ("missing" `isInfixOf` s) -- check what happens if the patch bundle has a wrong hash test_wrongBundleHash = withRepoRoot $@@ -126,6 +128,7 @@ wrongHash = case hash of ('1':xs) -> '2':xs (_:xs) -> '1':xs+ _ -> [] l' = reverse (wrongHash : (tail (reverse l))) s' = unlines l' writeFile "bundle_wrong_hash" s'@@ -280,3 +283,14 @@ " Woerter bestehen aus Buchstaben, Worte bestehen aus Gedanken.", " vgl. http://www.spiegel.de/kultur/zwiebelfisch/0,1518,307445,00.html", "]"]++test_encodingWrong =+ bracketCD "tests/encoding-problem" $+ withTempDirNoCD "A" $+ do bracketCD "A" (runIO "darcs init")+ bundle <- B.readFile "problem.dpatch"+ eith <- readPatchBundle "A" bundle+ content <- assertRight eith+ let patches = pbc_patches content+ assertEqual 2 (length patches)+ putStrLn (show patches)
src/DPM/Tutorial.hs view
@@ -116,7 +116,9 @@ Now Dave Developer receives an email stating that has patch has been rejected. The email also contains the full review so that Dave sees why the patch has been rejected. Thus, Dave starts fixing the bug, does an-@amend-record@ of the patch, and finally sends the patch again:+@amend-record@ of the patch, and finally sends the patch again.+(Alternatively, he could also create a new patch with exactly the same name+as the original patch.) > $ darcs send MAIN_REPO > Tue Mar 16 16:55:09 CET 2010 Dave Developer <dave@example.com>@@ -156,7 +158,7 @@ > Marked patch 2481 as reviewed > Send review to Dave Developer <dave@example.com>? [y/N] n -At this point, Richard Developer applies the patch with the very cool+At this point, Richard Reviewer applies the patch with the very cool feature: > $ dpm apply 2481
src/DPM/UI/Commandline/Commands.hs view
@@ -6,7 +6,6 @@ markAsReviewed, markAsUndecided, markAsObsolete, markAsRejected, openGroup, closeGroup, addComment, viewPatch, exportBundle, markAsApplied, markAsUnapplied- ) where import qualified Data.ByteString as B@@ -461,11 +460,13 @@ pid <- resolvePID allPIDs shortPID fname <- liftDPM $ S.getPatchFile pid p <- getPatch pid- liftIO $ do patchData <- gzReadFilePS fname- hPutStrLn handle (show (renderPatchName p))+ patchData <- liftIO $ gzReadFilePS fname+ liftIO $ do hPutStrLn handle (show (renderPatchName p)) hPutStrLn handle ""- cleaned <- cleanupBundle p patchData- B.hPut handle cleaned+ debug "Cleaning up bundle..."+ cleaned <- liftIO $ cleanupBundle p patchData+ debug "Finished cleaning up bundle..."+ liftIO $ do B.hPut handle cleaned hPutStrLn handle "" where handle = stdout
src/DPM/UI/Commandline/Main.hs view
@@ -30,8 +30,9 @@ import DPM.UI.Commandline.Interaction ( bugHeader ) import DPM.UI.Commandline.CDPM_Monad +-- keep in sync with version in .cabal file versionString :: String-versionString = "DPM version 0.1.0"+versionString = "DPM version 0.3.0" data Options = Options { opt_repoDir :: FilePath , opt_storageDir :: FilePath@@ -409,7 +410,7 @@ `catches` [Handler (\(DPMException err) -> abort err exitCodeFailure)- ,Handler (\e@(ExitFailure code) ->+ ,Handler (\(e::ExitCode) -> exitWith e) ,Handler (\(e::AsyncException) -> case e of