s-cargot-letbind 0.1.0.0 → 0.2.0.0
raw patch · 4 files changed
+203/−28 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Data.SCargot.LetBind: discoverLetBindings :: (Monoid str, IsString str, Show str, Eq a) => DiscoveryGuide a str -> SExpr a -> SExpr a
+ Data.SCargot.LetBind: discoverLetBindings :: (Monoid str, IsString str, Eq str, Eq a, Show a) => DiscoveryGuide a str -> SExpr a -> SExpr a
Files
- ChangeLog.md +15/−1
- s-cargot-letbind.cabal +1/−1
- src/Data/SCargot/LetBind.hs +84/−22
- test/SCargotPrintParseLet.hs +103/−4
ChangeLog.md view
@@ -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.
s-cargot-letbind.cabal view
@@ -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:
src/Data/SCargot/LetBind.hs view
@@ -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
test/SCargotPrintParseLet.hs view
@@ -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)