diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,20 @@ # Revision history for s-cargot-letbind +## 0.2.0.0 -- 2018-02-16 + + * Added verification ability to ensure let-bind variables are + always unique with respect to each-other and with respect to all + generated symbol strings within the s-expression. This is + performed internally within the 'discoverLetBindings' function, + but requires the ability to get the string representation of an + S-expression atom, so the 'extractStr' function is added to the + 'DiscoveryGuide' to support this. If not provided, or if the + provided form returns Nothing, no validation will be performed. + + * Suppress generation of let-binding phrase if there are no + discovered bindings to apply. + ## 0.1.0.0 -- 2018-02-14 - * Initial version. + * Initial version. diff --git a/s-cargot-letbind.cabal b/s-cargot-letbind.cabal --- a/s-cargot-letbind.cabal +++ b/s-cargot-letbind.cabal @@ -1,5 +1,5 @@ name: s-cargot-letbind -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Enables let-binding and let-expansion for s-cargot defined S-expressions. description: diff --git a/src/Data/SCargot/LetBind.hs b/src/Data/SCargot/LetBind.hs --- a/src/Data/SCargot/LetBind.hs +++ b/src/Data/SCargot/LetBind.hs @@ -20,7 +20,7 @@ import Control.Applicative import qualified Data.Foldable as F import Data.Function (on) -import Data.List (sortBy) +import Data.List ( sortBy, intercalate ) import Data.Maybe import Data.Monoid import Data.SCargot.Repr @@ -113,20 +113,20 @@ -- | Called to convert a plain S-expression into one with let-bound -- variables. The let bindings are "discovered" with the assistance -- of the guide. -discoverLetBindings :: (Monoid str, IsString str, Show str, Eq a) => +discoverLetBindings :: (Monoid str, IsString str, Eq str, Eq a, Show a) => DiscoveryGuide a str -> SExpr a -> SExpr a discoverLetBindings guide inp = let (inpMap,annotInp) = explore guide startingLoc inp - -- KWQ: locs rec v.s. let selections? locs = bestBindings guide annotInp $ points inpMap lbn = assignLBNames guide inp locs - -- varNameCollisions = verifyNamesUnique guide lbn inp + varNameCollisions = verifyNamesUnique guide lbn inp letPart = SAtom $ letMaker guide "let" (lbvdefs, subsInp) = substLBRefs guide lbn annotInp - in SCons letPart $ SCons lbvdefs (SCons subsInp SNil) - -- in if null varNameCollisions - -- then SCons letPart $ SCons lbvdefs (SCons subsInp SNil) - -- else error $ "Let-bound variable name collisions: " <> show varNameCollisions + in if null varNameCollisions + then if null lbn + then inp + else SCons letPart $ SCons lbvdefs (SCons subsInp SNil) + else error $ verificationFailureReport locs varNameCollisions {- $intro @@ -249,11 +249,6 @@ startingLoc :: MyMap a startingLoc = MyMap [] --- verifyNamesUnique :: IsString str => DiscoveryGuide a str -> [NamedLoc a] -> SExpr a -> [str] --- verifyNamesUnique guide names sexpr = foldr (checkUnique sexpr) [] names --- where checkUnique sexpr nloc = maybe [] F. find (extractStr guide) --- checkf = maybe ? F. find $ extractStr guide - data ExprInfo a = EINil | EIAtom a | EICons LocationId (ExprInfo a) (ExprInfo a) @@ -287,17 +282,84 @@ fndLoc e@(EICons el l r) = if el == loc then Just e else fndLoc l <|> fndLoc r -assignLBNames :: (Eq a, IsString str, Monoid str) => +assignLBNames :: (Show a, Eq a, IsString str, Monoid str) => DiscoveryGuide a str -> SExpr a -> [Location a] -> [NamedLoc a] -assignLBNames guide inp = snd . mapAccumL mkNamedLoc (1::Int) - where mkNamedLoc i l = let nm = labelMaker guide suggestedName $ locExpr l - suggestedName = "var" <> fromString (show i) - in case F.find ((==) nm) inp of - Nothing -> (i+1, NamedLoc { nlocId = locId l - , nlocVar = SAtom nm - }) - Just _ -> mkNamedLoc (i+1) l -- collision, try another varname +assignLBNames guide inp = snd . mapAccumL mkNamedLoc (1::Int, 0::Int) + where mkNamedLoc (i,t) l = let nm = labelMaker guide suggestedName $ locExpr l + suggestedName = "var" <> fromString (show i) + in case F.find ((==) nm) inp of + Nothing -> ((i+1,0), NamedLoc { nlocId = locId l + , nlocVar = SAtom nm + }) + Just _ -> if t < 100 + then mkNamedLoc (i+1,t+1) l -- collision, try another varname + else error $ "Too many failed attempts \ + \to generate a unique let var name: " <> show nm + +type UniquenessResult a = [(NamedLoc a, [Either (NamedLoc a) (SExpr a)])] + +verifyNamesUnique :: (IsString str, Eq str, Eq a) => + DiscoveryGuide a str + -> [NamedLoc a] + -> SExpr a + -> UniquenessResult a +verifyNamesUnique guide names sexpr = + foldr checkUniqueInExpr (checkUniqueNames names) names + where + varname (SAtom a) = atom2str a + varname _ = Nothing + atom2str = extractStr guide + checkUniqueInExpr nloc dups = + let locname = varname $ nlocVar nloc + addDup [] otherexp = [(nloc, [Right otherexp])] + addDup ((l,dl):dls) subexp = if nlocId l == nlocId nloc + then (nloc, Right subexp : dl) : dls + else addDup dls subexp + matchExpHead s e@(SAtom a) = if Just s == atom2str a + then Just e + else Nothing + matchExpHead s e@(SCons (SAtom a) r) = if Just s == atom2str a + then Just e + else matchExpHead s r + matchExpHead _ SNil = Nothing + matchExpHead s (SCons l r) = matchExpHead s l <|> matchExpHead s r + in case locname of + Nothing -> dups + Just nstr -> maybe dups (addDup dups) $ matchExpHead nstr sexpr + + checkUniqueNames = fmap (fmap (fmap Left)) . snd + . splitDups . foldr combineDups [] + combineDups nloc [] = [(nloc, [])] + combineDups nloc ((d,ls):ds) = if nlocVar nloc == nlocVar d + then (d,nloc:ls):ds + else (d,ls) : combineDups nloc ds + splitDups = let isDup (nloc, []) (u,d) = (nloc:u, d) + isDup e (u,d) = (u, e:d) + in foldr isDup ([],[]) + + +verificationFailureReport :: Show a => [Location a] -> UniquenessResult a -> String +verificationFailureReport locs = intercalate "\n" . fmap vfRep + where vfRep (l, vf) = + let fs = fmap fl vf + fl (Left nloc) = var nloc + fl (Right e) = "other portion of S-expression: " + <> (show $ truncateExpr 4 e) + var v = "let variable \"" <> (show $ nlocVar v) + <> "\" [" + <> (show $ (truncateExpr 2 . locExpr) <$> + F.find ((==) (nlocId v) . locId) locs) + <> " ...]" + in intercalate "\n " $ + ("ERR: duplicated " <> (var l) <> " at: ") : fs + +truncateExpr :: Int -> SExpr a -> SExpr a +truncateExpr _ SNil = SNil +truncateExpr _ e@(SAtom _) = e +truncateExpr 0 _ = SNil +truncateExpr n (SCons l r) = let trunc = truncateExpr (n - 1) + in SCons (trunc l) (trunc r) substLBRefs :: Eq a => DiscoveryGuide a str -> [NamedLoc a] -> ExprInfo a diff --git a/test/SCargotPrintParseLet.hs b/test/SCargotPrintParseLet.hs --- a/test/SCargotPrintParseLet.hs +++ b/test/SCargotPrintParseLet.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Main where +import Control.Exception import Data.Either +import Data.List import Data.SCargot import Data.SCargot.Comments import Data.SCargot.LetBind @@ -19,7 +21,6 @@ main = do - putStrLn "Parsing a large S-expression" srcs <- mapM (\n -> (,) n <$> TIO.readFile n) [ "test/small-sample.sexp" , "test/med-sample.sexp" , "test/med2-sample.sexp" @@ -85,8 +86,103 @@ SNil))) ] ] - , TestLabel "round-trip" $ TestList $ - concatMap (\t -> map t srcs) $ + + , TestLabel "let bind corner cases" $ + let pprintIt = pprintSExpr 40 Swing + guide = (nativeGuide AIdent (\n _ -> AIdent n)) + { extractStr = Just . T.unpack . printAtom + } + samenames = guide + { labelMaker = \_ _ -> AIdent "samevar" + , minExprSize = 2 + } + peoplenames = guide + { labelMaker = \s e -> AIdent + $ case e of + (SCons (SAtom (AIdent "welt")) _) -> "people" + _ -> s + , minExprSize = 2 + , weighting = \e c -> + case e of + (SCons (SAtom (AIdent "welt")) _) -> 1000000 + _ -> weighting guide e c + } + hinames = peoplenames + { labelMaker = \s e -> AIdent + $ case e of + (SCons (SAtom (AIdent "welt")) _) -> "hi" + _ -> s + } + nobindGuide = guide { weighting = \_ _ -> 0 } + throws t estrs = catch (evaluate t >> pure False) $ + \(ErrorCall e) -> (mapM (assertInString e) estrs >> pure True) + -- \(ErrorCall e) -> assertInString estrs e + -- \(ErrorCall e) -> mapM (assertBool "chk" . isInfixOf e) estrs + -- \(ErrorCall e) -> pure $ and $ fmap (assertBool "chk" . isInfixOf e) estrs + assertInString whole part = assertBool ("String \"" <> part <> "\" not in \"" <> whole <> "\"") $ + part `isInfixOf` whole + checkStrs :: [String] -> String -> IO Bool + checkStrs estrs e = mapM (assertBool "chk" . isInfixOf e) estrs >> pure True + sexpr f = (SCons (SCons (SAtom (AIdent "hi")) + (SCons (SAtom (AIdent "world")) + (SCons (SAtom (AIdent "and")) + (SCons f + SNil)))) + (SCons (SAtom (AIdent "hallo")) + (SCons (SAtom (AIdent "welt")) + (SCons (SAtom (AIdent "und")) + (SCons (SAtom (AIdent "leute")) + SNil))))) + normalf = (SAtom (AIdent "people")) + in TestList + [ TestLabel "trivial let binding" $ + "((hi world and people)\n hallo\n welt\n und\n leute)\n" ~=? + (pprintIt $ discoverLetBindings nobindGuide $ sexpr normalf) + + , TestLabel "duplicate names" $ + TestCase (assertBool "No error on duplicate bindings" =<< + throws (pprintIt $ discoverLetBindings samenames $ sexpr normalf) + [ "duplicated let variable" + , "people" + , " let variable" + ]) + + , TestLabel "expected bindings for these tests" $ + "(let\n\ + \ ((people (welt und leute))\n\ + \ (var1 (world and last)))\n\ + \ ((hi var1) hallo people))\n" ~=? + (pprintIt $ discoverLetBindings peoplenames + $ sexpr (SAtom (AIdent "last"))) + , TestLabel "expression ident names collision above bind point" $ + TestCase (assertBool "No expected error on duplicate bindings" =<< + throws (pprintIt $ discoverLetBindings hinames + $ sexpr normalf) + [ "Too many failed attempts" + , "unique let var name" + , "hi" + ]) + , TestLabel "expression ident names collision below bind point" $ + TestCase (assertBool "No expected error on duplicate bindings" =<< + throws (pprintIt $ discoverLetBindings peoplenames + $ sexpr normalf) + [ "Too many failed attempts" + , "unique let var name" + , "people" + ]) + , TestLabel "expression string-only collision names" $ + TestCase (assertBool "No expected error on duplicate bindings" =<< + throws (pprintIt $ discoverLetBindings peoplenames + $ sexpr (SAtom (AMarker "people"))) + [ "duplicated let variable" + , "people" + , "other portion of S-expression" + ]) + ] + + , TestLabel "round-trip" $ + let pprintIt = pprintSExpr 40 Swing in TestList $ + concatMap (\t -> map t srcs) [ testParsePrint ] ] @@ -168,6 +264,8 @@ | AQuoted String | AString String | AInt Integer + | AMarker String -- ambiguous, but duplicates AIdent in + -- output; used for collision tests | ABV Int Integer deriving (Eq, Show) @@ -192,6 +290,7 @@ printAtom a = case a of AIdent s -> T.pack s + AMarker s -> T.pack s AQuoted s -> T.pack ('\'' : s) AString s -> T.pack (show s) AInt i -> T.pack (show i)