diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml new file mode 100644 index 0000000..34f0d3c --- /dev/null +++ b/.github/workflows/haskell.yml @@ -0,0 +1,38 @@ +name: Haskell CI + +on: + push: + branches: [ "master" ] + pull_request: + branches: [ "master" ] + +permissions: + contents: read + +jobs: + + hlint: + name: Run HLint on the QuickCheck Verification Engine codebase + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - name: 'Set up HLint' + uses: haskell-actions/hlint-setup@v2 + - name: 'Run HLint' + uses: haskell-actions/hlint-run@v2 + + build: + name: Build the QuickCheck Verification Engine + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - uses: haskell-actions/setup@v2 + with: + ghc-version: '9.8' + cabal-version: '3.8' + - name: Install dependencies + run: | + cabal update + cabal build --only-dependencies + - name: Build + run: cabal build all diff --git a/src/InstrCodec.hs b/src/InstrCodec.hs index 6d3e8e8..e7cd4bb 100644 --- a/src/InstrCodec.hs +++ b/src/InstrCodec.hs @@ -39,7 +39,7 @@ module InstrCodec where import Data.Char -import Data.List +import Data.List (nub) import Data.Maybe import Data.Bits import Test.QuickCheck @@ -90,7 +90,7 @@ tokenise = init [] where n = read ds :: Int close acc (']':cs) = init acc cs - close acc other = error "Format error: expected ']'" + close _ _ = error "Format error: expected ']'" lit acc cs = init (Lit s : acc) (dropWhile isBit cs) where s = reverse (takeWhile isBit cs) @@ -102,12 +102,12 @@ data TaggedToken = Tag Int Token tag :: [Token] -> [TaggedToken] tag = tagger 0 where - tagger n [] = [] + tagger _ [] = [] tagger n (t:ts) = case t of Lit bs -> Tag n t : tagger (n + length bs) ts - Var v -> error "tag: unranged vars not supported" - Range v hi lo -> Tag n t : tagger (n + (hi-lo) + 1) ts + Var _ -> error "tag: unranged vars not supported" + Range _ hi lo -> Tag n t : tagger (n + (hi-lo) + 1) ts -- Mapping from var bit-index to subject bit-index type Mapping = [(Int, Int)] @@ -125,30 +125,30 @@ subst m bs = unscatter [(bi, bs !! si) | (bi, si) <- m] unscatter :: [(Int, a)] -> [a] unscatter = join 0 where - join i [] = [] + join _ [] = [] join i m = case [x | (j, x) <- m, i == j] of [] -> error "Format error: non-contiguous variable assignment" [x] -> x : join (i+1) [p | p <- m, fst p /= i] - other -> error "Format error: overlapping variable assignment" + _ -> error "Format error: overlapping variable assignment" -- Determine argument values to right-hand-side -args :: BitList -> [TaggedToken] -> [BitList] -args subj = get . reverse +rhsArgs :: BitList -> [TaggedToken] -> [BitList] +rhsArgs subj = get . reverse where - notVar v (Tag i (Range w hi lo)) = v /= w - notVar v other = False + notVar v (Tag _ (Range w _ _)) = v /= w + notVar _ _ = False get [] = [] - get ts@(Tag i (Range v hi lo) : rest) = + get ts@(Tag _ (Range v _ _) : rest) = subst (mapping v ts) subj : get (filter (notVar v) rest) - get (t:ts) = get ts + get (_:ts) = get ts -- Determine width of a token tokenWidth :: Token -> Int -tokenWidth (Var v) = error "Error: tokenWidth not defined for unranged vars" -tokenWidth (Range v hi lo) = (hi-lo)+1 +tokenWidth (Var _) = error "Error: tokenWidth not defined for unranged vars" +tokenWidth (Range _ hi lo) = (hi-lo)+1 tokenWidth (Lit bs) = length bs -- Match literals in pattern against subject @@ -159,11 +159,11 @@ matches subj toks where width = sum (map tokenWidth toks) - check n [] = True + check _ [] = True check n (t : rest) = case t of - Var v -> error "Format error: unranged vars not supported" - Range id hi lo -> check (n + (hi-lo) + 1) rest + Var _ -> error "Format error: unranged vars not supported" + Range _ hi lo -> check (n + (hi-lo) + 1) rest Lit bs -> and [ if c == '0' then not b else b | (c, b) <- zip bs (drop n subj) ] @@ -193,10 +193,10 @@ class Apply f a where instance Apply f f where apply f [] = f - apply f other = error "Format error: too many pattern vars" + apply _ _ = error "Format error: too many pattern vars" instance Apply f a => Apply (Integer -> f) a where - apply f [] = error "Format error: too few pattern vars" + apply _ [] = error "Format error: too few pattern vars" apply f (arg:args) = apply (f (fromBitList arg)) args decodeOne :: Apply f a => String -> f -> (Instruction, Int) -> Maybe a @@ -207,7 +207,7 @@ decodeOne fmt rhs = subj' = w#subj in if matches subj' toks - then Just $ apply rhs (args subj' (tag toks)) + then Just $ apply rhs (rhsArgs subj' (tag toks)) else Nothing type DecodeBranch a = (Instruction, Int) -> Maybe a @@ -220,17 +220,17 @@ decode :: Int -> Instruction -> [(Instruction, Int) -> Maybe a] -> Maybe a decode n subj alts = case catMaybes [alt (subj, n) | alt <- alts] of [] -> Nothing - match:rest -> Just match + match:_-> Just match rangedVars :: [Token] -> [String] -rangedVars toks = nub [v | Range v hi lo <- reverse toks] +rangedVars toks = nub [v | Range v _ _ <- reverse toks] scatter :: [Token] -> [(String, Integer)] -> BitList -scatter [] env = [] +scatter [] _ = [] scatter (tok:toks) env = case tok of Lit bs -> [b == '1' | b <- bs] ++ scatter toks env - Var v -> error "Codec.scatter: unranged vars not supported" + Var _ -> error "Codec.scatter: unranged vars not supported" Range v hi lo -> case lookup v env of Nothing -> error ("Unknown variable " ++ v) diff --git a/stack.yaml b/stack.yaml index 25c1558..b00bab5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-20.1 +resolver: lts-20.9 # User packages to be built. packages: @@ -7,4 +7,4 @@ packages: # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. extra-deps: -- bitwise-1.0.0.1 # not included in the default resolver set + - bitwise-1.0.0.1 # not included in the default resolver set diff --git a/stack.yaml.lock b/stack.yaml.lock index 0338054..7543e8d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -7,13 +7,13 @@ packages: - completed: hackage: bitwise-1.0.0.1@sha256:04c0e0c65a9228d9e004b5c4b08633b2f0e915afe8f3affc9bd16f75f92ccf61,3110 pantry-tree: - size: 760 sha256: fe95409d2e77769965df68eade44e6eb5fcc63643a94e2645cd5db357670b20f + size: 760 original: hackage: bitwise-1.0.0.1 snapshots: - completed: - size: 648424 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml - sha256: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5 - original: lts-20.1 + sha256: c11fcbeb1aa12761044755b1109d16952ede2cb6147ebde777dd5cb38f784501 + size: 649333 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/9.yaml + original: lts-20.9 diff --git a/weeder.dhall b/weeder.dhall new file mode 100644 index 0000000..0e873ea --- /dev/null +++ b/weeder.dhall @@ -0,0 +1 @@ +{ roots = [ "^Main.main$" ], type-class-roots = True }