diff --git a/brat/Brat/Checker/Helpers.hs b/brat/Brat/Checker/Helpers.hs index 39b8ea3..f58ac82 100644 --- a/brat/Brat/Checker/Helpers.hs +++ b/brat/Brat/Checker/Helpers.hs @@ -101,27 +101,27 @@ pullPortsRow :: Show ty => [PortName] -> [(NamedPort e, ty)] -> Checking [(NamedPort e, ty)] -pullPortsRow = pullPorts portName showRow +pullPortsRow = pullPorts (portName . fst) showRow pullPortsSig :: Show ty => [PortName] -> [(PortName, ty)] -> Checking [(PortName, ty)] -pullPortsSig = pullPorts id showSig +pullPortsSig = pullPorts fst showSig pullPorts :: forall a ty . (a -> PortName) -- A way to get a port name for each element - -> ([(a, ty)] -> String) -- A way to print the list + -> ([a] -> String) -- A way to print the list -> [PortName] -- Things to pull to the front - -> [(a, ty)] -- The list to rearrange - -> Checking [(a, ty)] + -> [a] -- The list to rearrange + -> Checking [a] pullPorts toPort showFn to_pull types = -- the "state" here is the things still available to be pulled (\(pulled, rest) -> pulled ++ rest) <$> runStateT (mapM pull1Port to_pull) types where - pull1Port :: PortName -> StateT [(a, ty)] Checking (a, ty) - pull1Port p = StateT $ \available -> case partition ((== p) . toPort . fst) available of - ([], _) -> err $ BadPortPull $ "Port not found: " ++ p ++ " in " ++ showFn available + pull1Port :: PortName -> StateT [a] Checking a + pull1Port p = StateT $ \available -> case partition ((== p) . toPort) available of + ([], _) -> err $ BadPortPull p (showFn available) ([found], remaining) -> pure (found, remaining) (_, _) -> err $ AmbiguousPortPull p (showFn available) diff --git a/brat/Brat/Checker/SolvePatterns.hs b/brat/Brat/Checker/SolvePatterns.hs index 76e9e53..d903465 100644 --- a/brat/Brat/Checker/SolvePatterns.hs +++ b/brat/Brat/Checker/SolvePatterns.hs @@ -372,7 +372,7 @@ argProblems srcs na p = argProblemsWithLeftovers srcs na p >>= \case _ -> err $ UnificationError "Pattern doesn't match expected length for constructor args" argProblemsWithLeftovers :: [Src] -> NormalisedAbstractor -> Problem -> Checking (Problem, [Src]) -argProblemsWithLeftovers srcs (NA (APull ps abs)) p = pullPorts portName show ps (map (, ()) srcs) >>= \srcs -> argProblemsWithLeftovers (fst <$> srcs) (NA abs) p +argProblemsWithLeftovers srcs (NA (APull ps abs)) p = pullPorts portName show ps srcs >>= \srcs -> argProblemsWithLeftovers srcs (NA abs) p argProblemsWithLeftovers (src:srcs) na p | Just (pat, na) <- unconsNA na = first ((src, pat):) <$> argProblemsWithLeftovers srcs na p argProblemsWithLeftovers srcs (NA AEmpty) p = pure (p, srcs) argProblemsWithLeftovers [] abst _ = err $ NothingToBind (show abst) diff --git a/brat/Brat/Error.hs b/brat/Brat/Error.hs index 32cea48..f34dba1 100644 --- a/brat/Brat/Error.hs +++ b/brat/Brat/Error.hs @@ -9,6 +9,7 @@ module Brat.Error (ParseError(..) ) where import Brat.FC +import Brat.Syntax.Port (PortName) import Data.List (intercalate) import System.Exit @@ -60,8 +61,8 @@ data ErrorMsg | FileNotFound String [String] | SymbolNotFound String String | InternalError String - | AmbiguousPortPull String String - | BadPortPull String + | AmbiguousPortPull PortName String + | BadPortPull PortName String | VConNotFound String | TyConNotFound String String | MatchingOnTypes @@ -139,7 +140,7 @@ instance Show ErrorMsg where show (SymbolNotFound s i) = "Symbol `" ++ s ++ "` not found in `" ++ i ++ "`" show (InternalError x) = "Internal error: " ++ x show (AmbiguousPortPull p row) = "Port " ++ p ++ " is ambiguous in " ++ row - show (BadPortPull x) = "Port " ++ x ++ " can't be pulled because it depends on a previous port" + show (BadPortPull p row) = "Port not found: " ++ p ++ " in " ++ row show (VConNotFound x) = "Value constructor not recognised: " ++ x show (TyConNotFound ty v) = show v ++ " is not a valid constructor for type " ++ ty show MatchingOnTypes = "Trying to pattern match on a type"